Using replacement in VBA

Question

I have about 17 thousand emails containing orders, news, contacts, etc., which returned 11 years ago.

User email addresses were encrypted to stop scanners and spam by changing @ to *@ * or 'at .

I am trying to create a macro to view emails and create a comma delimited list so that we can create a database of our users.

This is not my past work, by the way, I just got a joyful task to see if we can get all the data from these old letters.

I know that the code below works with file writing and folder cyclization, because if I write the senders email address to the file in which I now use the body of the letter, then it prints fine.

The problem I encountered is that Replaces are not working. They do not change *at* etc. On @ .

First of all, why not, and secondly, the best way for me to do this as a whole?

current code

 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 hacked this to extract emails such as this sample, below which the three email addresses in yellow in the example below will be output to the csv file

• Any valids emails are written to the csv file Set objTF = objFSO.createtextfile("c:\myemail.csv")
• This code scans all emails in a folder named temp under Inbox . I carve out the recursive part of testing and simplicity
• There are four string manipulations
• This line converts any unused spaces to regular spaces strMsgBody = Replace(strMsgBody, Chr(160), Chr(32) (unlikely, but this happened in my testing)
• Regex1 converts any "at" or "at" values, etc. in "@" "(\s+at\s+|'at'|<at>|\*at\*|at)"
• Regex2 converts any "point" or "point", etc. in ".". "(\s+dot\s+|'dot'|<dot>|\*dot\*|dot)"
• Regex3 converts any of the "<" ">" or ":" to "" .Pattern = "[<:>]"
• Regex4 instance any valid email from email

• 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 

Answer 2

How to use regex (regex)?

Sort of:

 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 

Just replace the regex with all the cases you might get.
See http://www.regular-expressions.info/ for more tips and information.