如何用@替换'at'

Question

我有大约 17,000 封电子邮件，其中包含 11 年前的订单、新闻、联系人等。

通过将@ 更改为*@* 或'at'，用户的电子邮件地址已被粗略地加密以阻止爬虫和垃圾邮件。

我正在尝试创建一个逗号分隔的列表来构建我们用户的数据库。

该代码适用于编写文件和循环文件夹，因为如果我将发件人电子邮件地址写入我当前使用电子邮件正文的文件，那么它可以正常打印。

问题是，Replaces 没有将 *at* 等更改为 @。

1. 首先，为什么不呢？
2. 有没有更好的方法让我整体上做到这一点？

Private Sub Form_Load()

   Dim objOutlook As New Outlook.Application
   Dim objNameSpace As Outlook.NameSpace
   Dim objInbox As MAPIFolder
   Dim objFolder As MAPIFolder
   Dim fldName As String

   fldName = "TEST"

   ' Get the MAPI reference

   Set objNameSpace = objOutlook.GetNamespace("MAPI")

   ' Pick up the Inbox

   Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)

   'Loop through the folders under the Inbox
   For Each objFolder In objInbox.Folders
       RecurseFolders fldName, objFolder
   Next objFolder

End Sub

Public Sub RecurseFolders(targetFolder As String, currentFolder As MAPIFolder)
   If currentFolder.Name = targetFolder Then
       GetEmails currentFolder
   Else
       Dim objFolder As MAPIFolder
       If currentFolder.Folders.Count > 0 Then
           For Each objFolder In currentFolder.Folders
               RecurseFolders targetFolder, objFolder
           Next
       End If
     End If
End Sub

Sub WriteToATextFile(e As String)
    MyFile = "c:\" & "emailist.txt"
    'set and open file for output
    fnum = FreeFile()
    Open MyFile For Append As fnum
    Print #fnum, e; ","
    Close #fnum
End Sub

Sub GetEmails(folder As MAPIFolder)
    Dim objMail As MailItem

    ' Read through all the items
    For i = 1 To folder.Items.Count
        Set objMail = folder.Items(i)
        GetEmail objMail.Body              
    Next i

End Sub

Sub GetEmail(s As String)
    Dim txt = s
    Do Until InStr(txt, "@") <= 0
        Dim tleft As Integer
        Dim tright As Integer
        Dim start As Integer
        Dim text As String
        Dim email As String

        text = Replace(text, " at ", "@", VbCompareMethod.vbTextCompare)
        text = Replace(text, "'at'", "@", VbCompareMethod.vbTextCompare)
        text = Replace(text, "*at*", "@", VbCompareMethod.vbTextCompare)
        text = Replace(text, "*at*", "@", VbCompareMethod.vbTextCompare)

        text = Replace(text, "<", " ", VbCompareMethod.vbTextCompare)
        text = Replace(text, ">", " ", VbCompareMethod.vbTextCompare)
        text = Replace(text, ":", " ", VbCompareMethod.vbTextCompare)

        'one two ab@bd.com one two
        tleft = InStr(text, "@") '11

        WriteToATextFile Str(tleft)
        WriteToATextFile Str(Len(text))

        start = InStrRev(text, " ", Len(text) - tleft)
        'WriteToATextFile Str(start)
        'WriteToATextFile Str(Len(text))
        'start = Len(text) - tleft
        text = left(text, start)
        'ab@bd.com one two

        tright = InStr(text, " ") '9
        email = left(text, tright)
        WriteToATextFile email

        text = right(text, Len(text) - Len(email))
        GetEmail txt
    Loop
End Sub

Answer 1

使用正则表达式（正则表达式）怎么样？

类似：

Public Function ReplaceAT(ByVal sInput as String)
     Dim RegEx As Object
     Set RegEx = CreateObject("vbscript.regexp")
     With RegEx
      .Global = True
      .IgnoreCase = True
      .MultiLine = True
      .Pattern = "( at |'at'|<at>)"
     End With
     ReplaceAT = RegEx.Replace(sInput, "@")
     Set RegEx = Nothing
End Function

只需将正则表达式替换为您可能遇到的每种情况。
有关更多提示和信息，请参阅http://www.regular-expressions.info/。

Answer 2

我已经对此进行了破解以提取电子邮件，例如下面的示例，它将下面示例消息中黄色的三个电子邮件地址提取到 csv 文件中

1. 任何有效的电子邮件都会写入 csv 文件 Set objTF = objFSO.createtextfile("c:\myemail.csv")
2. 此代码扫描Inbox 下名为temp 的文件夹中的所有 电子邮件我删除了您的递归部分的测试和简单性
3. 有四种字符串操作
4. 此行将任何非打印空格转换为普通空格strMsgBody = Replace(strMsgBody, Chr(160), Chr(32)（不太可能，但它发生在我的测试中）
5. Regex1 将任何“at”或“at”等转换为“@”"(\s+at\s+|'at'|<at>|\*at\*|at)"
6. Regex2 将任何“点”或“点”等转换为“.” "(\s+dot\s+|'dot'|<dot>|\*dot\*|dot)"
7. Regex3 将 "" 或 ":" 中的任何一个转换为 "" .Pattern = "[<:>]"
8. Regex4 从电子邮件正文中提取任何有效电子邮件

9. 任何有效的电子邮件都会使用objTF.writeline objRegM 写入 csv 文件

代码如下

Public Test()
Dim objOutlook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objFolder As MAPIFolder
Dim strfld As String
Dim objRegex As Object
Dim objRegMC As Object
Dim objRegM As Object
Dim objFSO As Object
Dim oMailItem As MailItem
Dim objTF As Object
Dim strMsgBody As String    
Set objRegex = CreateObject("vbscript.regexp")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile("c:\myemail.csv")

With objRegex
    .Global = True
    .MultiLine = True
    .ignorecase = True
    strfld = "temp"
    'Get the MAPI reference
    Set objNameSpace = objOutlook.GetNamespace("MAPI")
    'Pick up the Inbox
    Set objFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
    Set objFolder = objFolder.Folders(strfld)
    For Each oMailItem In objFolder.Items
        strMsgBody = oMailItem.Body
        strMsgBody = Replace(strMsgBody, Chr(160), Chr(32))
        .Pattern = "(\s+at\s+|'at'|<at>|\*at\*|at)"
        strMsgBody = .Replace(strMsgBody, "@")
        .Pattern = "(\s+dot\s+|'dot'|<dot>|\*dot\*|dot)"
        strMsgBody = .Replace(strMsgBody, ".")
        .Pattern = "[<:>]"
        strMsgBody = .Replace(strMsgBody, vbNullString)
        .Pattern = "[\w-\.]{1,}\@([\da-zA-Z-]{1,}\.){1,}[\da-zA-Z-]{2,3}"
        If .Test(strMsgBody) Then
            Set objRegMC = .Execute(strMsgBody)
            For Each objRegM In objRegMC
                objTF.writeline objRegM
            Next
        End If
    Next
End With
objTF.Close
End Sub