Question

我的搜索目的是为Outlook创建一个脚本：

从所选收件箱电子邮件正文中删除密码字段
＆安培;将其保存到硬盘驱动器到设置文件夹以进行管理目的。

所以基本上每封电子邮件都包含“password：xyz”这样的行我不想删除常量部分“password：”，只删除它后面的动态部分。通过删除关键字后面的整行，或者用足够长的字符串覆盖动态部分，例如“从此副本中删除PW”或类似字符串。

我可以弄清楚如何搜索邮件正文中的给定文本，以及如何替换它，或者如何将文本插入邮件正文中，但我找不到任何地方，如何修改（删除或过度怀疑）文本在搜索词之后而不是搜索词本身。

我的演示代码现在处于此阶段:(仅允许替换已知文本，但无法使用它来访问未知部分）（（你可以看到我的代码包含像“.insertbefore”这样的关闭行;我正在尝试使用这种方法，但是没有成功，所以暂时将其关闭））

Public Sub SaveMessageAsMsg()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sPath, strFolderpath As String
    Dim dtDate As Date
    Dim sName As String
    Dim enviro As String
    Dim body As String

    enviro = CStr(Environ("USERPROFILE"))

    sPath = "D:\Demo\"

    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem
            sName = oMail.Subject
            body = oMail.body
            body = Replace(body, "Password:", "Password: -Removed-")
            'objSel.InsertBefore strText
            oMail.body = body
            'Debug.Print sPath & sName
            oMail.SaveAs sPath & sName & ".msg", olMSG
         End If
    Next
End Sub

Answer 1

此处介绍了“从包含结构化文本的邮件中提取信息”的方法Parsing text from a message body。

代码看起来像这样：

option explicit

Public Sub SaveMessageAsMsg()

    Dim objItem As Object
    Dim sPath As String
    Dim strFolderpath As String

    Dim sName As String
    Dim enviro As String

    Dim strPswd As String
    Dim strAll as String

    enviro = CStr(Environ("USERPROFILE"))

    sPath = "D:\Demo\"

    For Each objItem In ActiveExplorer.Selection

        If objItem.MessageClass = "IPM.Note" Then

            sName = objItem.Subject

            strPswd = ParseTextLinePair(objItem.body, "Password:")

            ' If strPswd is reliably unique in the message
            ' objItem.body = Replace(objItem.body, strPswd, "-Removed-")

            ' To be safe, carefully determine the exact label and text to replace,
            '   including the space, if any, after the colon
            strAll = "Password: " & strPswd
            Debug.Print strAll
            objItem.body = Replace(objItem.body, strAll, "Password: -Removed-")
            'Debug.Print sPath & sName
            objItem.SaveAs sPath & sName & ".msg", olMSG
         End If
    Next

End Sub

Function ParseTextLinePair(strSource As String, strLabel As String)
    Dim intLocLabel As Integer
    Dim intLocCRLF As Integer
    Dim intLenLabel As Integer
    Dim strText As String

    ' locate the label in the source text
    intLocLabel = InStr(strSource, strLabel)
    intLenLabel = Len(strLabel)
        If intLocLabel > 0 Then
        intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
        If intLocCRLF > 0 Then
            intLocLabel = intLocLabel + intLenLabel
            strText = Mid(strSource, _
                            intLocLabel, _
                            intLocCRLF - intLocLabel)
        Else
            intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
        End If
    End If
    ParseTextLinePair = Trim(strText)
End Function

Answer 2

好的伙计们最后我找到了解决方法，但我几乎没有相信，没有更简单的方法，所以，如果有人能提出更优雅的解决方案，请这样做（只是以正确的方式向它学习）

基本上我用了两次搜索来找到第一个已知单词的位置和文本中的下一个已知单词，从彼此中减去它们以得到它们之间的字符数，最后在它们之间粘贴一些字符串。

这种方法的好处至少是它确保我不会伤害下一行的内容，无论多长时间覆盖未知文本。

此解决方案的关键元素是MID语句。

Public Sub SaveMessageWithoutPW()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sPath, strFolderpath As String
    Dim sName As String
    Dim enviro As String
    Dim body As String
    Dim TestPos As Integer
    Dim EndPos As Integer
    Dim PosL As Integer

    enviro = CStr(Environ("USERPROFILE"))

    sPath = "D:\Demo\"

    For Each objItem In ActiveExplorer.Selection
        If objItem.MessageClass = "IPM.Note" Then
            Set oMail = objItem
            sName = oMail.Subject
            body = oMail.body
            TestPos = InStr(body, "Password") + 9 '+9 for Password itself
            EndPos = InStr(body, "Send an email")
            PosL = (EndPos - TestPos) - 1 '-1 For the linebreak
            Mid(body, TestPos, PosL) = " ******************************"
            'PosL defines how many * to use at most, not to hurt other content
            oMail.body = body
            oMail.SaveAs sPath & sName & ".msg", olMSG
         End If
    Next
End Sub

在给定关键字后删除或覆盖正文文本

2 个答案: