Question

I have about 17k emails containing orders, news, contacts etc. going back 11 years.

Users’ email addresses have been shoddily encrypted to stop crawlers and spam by changing the @ to either *@* or 'at'.

I am trying to create a comma separated list to build a database of our users.

The code works with writing the file and looping the folders because if I write the senders email address to the file where I am currently using the body of the email then it prints fine.

The problem is, the Replaces aren’t changing *at* etc to @.

1. First of all, why not?
2. Is there a better way for me to be doing this as a whole?

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 [e-mail] 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)
        '[e-mail] 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

I’ve taken a crack at this to extract emails such as this sample below which will take out the three email addresses in yellow in the sample message below to a csv file

1. Any valids emails are written to a csv file Set objTF = objFSO.createtextfile("c:\myemail.csv")
2. This code scans all emails in a folder called temp under Inbox I cut out your recursive portion of testing and simplicity
3. There are four string manipulations
4. This line converts any non printing blank spaces to normal spaces strMsgBody = Replace(strMsgBody, Chr(160), Chr(32) (unlikely but it happened in my testing)
5. Regex1 converts any ” at ” or “at” etc into “@” "(\s+at\s+|'at'|<at>|\*at\*|at)"

6. Regex2 converts any ” dot ” or “dot” etc into “.” "(\s+dot\s+|'dot'|<dot>|\*dot\*|dot)"
7. Regex3 converts any of “<” “>” or “:” into “” .Pattern = "[<:>]"
8. Regex4 extracts any valid email from the emailbody

9. Any valid emails are written to the csv file using objTF.writeline objRegM

   

Code below

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