Extract multiple email in a single Outlook message to Excel? - regex

Question

I need a macro in Outlook that extract all the email address in the outlook message then post it in excel.
The following code only extracts the very 1st email address it finds in the body.
My desired output should be:
adam.peters#sample.com
adam.dryburgh#sample.com
amy.norton#sample.com
My sample email is:
Delivery has failed to these recipients or groups:
adam.peters#sample.com The e-mail address you entered couldn't be
found. Please check the recipient's e-mail address and try to resend
the message. If the problem continues, please contact your helpdesk.
adam.dryburgh#sample.com The e-mail address you entered couldn't be
found. Please check the recipient's e-mail address and try to resend
the message. If the problem continues, please contact your helpdesk.
amy.norton#sample.com The e-mail address you entered couldn't be
found. Please check the recipient's e-mail address and try to resend
the message. If the problem continues, please contact your helpdesk.
The following organization rejected your message:
mx2.dlapiper.iphmx.com.
code:
Sub Extract_Invalid_To_Excel()
Dim olApp As Outlook.Application
Dim olExp As Outlook.Explorer
Dim olFolder As Outlook.MAPIFolder
Dim obj As Object
Dim stremBody As String
Dim stremSubject As String
Dim i As Long
Dim x As Long
Dim count As Long
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
Dim xlApp As Object 'Excel.Application
Dim xlwkbk As Object 'Excel.Workbook
Dim xlwksht As Object 'Excel.Worksheet
Dim xlRng As Object 'Excel.Range
Set olApp = Outlook.Application
Set olExp = olApp.ActiveExplorer
Set olFolder = olExp.CurrentFolder
'Open Excel
Set xlApp = GetExcelApp
xlApp.Visible = True
If xlApp Is Nothing Then GoTo ExitProc
Set xlwkbk = xlApp.workbooks.Add
Set xlwksht = xlwkbk.Sheets(1)
Set xlRng = xlwksht.Range("A1")
xlRng.Value = "Bounced email addresses"
'Set count of email objects
count = olFolder.Items.count
'counter for excel sheet
i = 0
'counter for emails
x = 1
For Each obj In olFolder.Items
xlApp.StatusBar = x & " of " & count & " emails completed"
stremBody = obj.Body
stremSubject = obj.Subject
'Check for keywords in email before extracting address
If checkEmail(stremBody) = True Then
'MsgBox ("finding email: " & stremBody)
RegEx.Pattern = "\b[A-Z0-9._%+-]+#[A-Z0-9.-]+\.[A-Z]{2,4}\b"
RegEx.IgnoreCase = True
RegEx.MultiLine = True
Set olMatches = RegEx.Execute(stremBody)
For Each match In olMatches
xlwksht.cells(i + 2, 1).Value = match
i = i + 1
Next match
'TODO move or mark the email that had the address extracted
Else
'To view the items that aren't being parsed uncomment the following line
'MsgBox (stremBody)
End If
x = x + 1
Next obj
xlApp.ScreenUpdating = True
MsgBox ("Invalid Email addresses are done being extracted")
ExitProc:
Set xlRng = Nothing
Set xlwksht = Nothing
Set xlwkbk = Nothing
Set xlApp = Nothing
Set emItm = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Sub
Function GetExcelApp() As Object
' always create new instance
On Error Resume Next
Set GetExcelApp = CreateObject("Excel.Application")
On Error GoTo 0
End Function

Answer 1

untested
replace
RegEx.Pattern = "\b[A-Z0-9._%+-]+#[A-Z0-9.-]+\.[A-Z]{2,4}\b"
RegEx.IgnoreCase = True
RegEx.MultiLine = True
with
RegEx.Pattern = "\b[A-Z0-9._%+-]+#[A-Z0-9.-]+\.[A-Z]{2,4}\b"
RegEx.IgnoreCase = True
RegEx.MultiLine = True
RegEx.Global = True

Answer 2

I have noticed the following line of code:
Set olApp = Outlook.Application
If you run the code in Outlook, you need to use the Application property to get an instance of the Application class. Or you need to use the New operator to create a new instance, for example:
Set ol = New Outlook.Application
or
Set objOL = CreateObject("Outlook.Application")
See How to automate Outlook from another program for more information.
You may also consider using the Word object model for working with item bodies. The WordEditor property of the Inspector class returns an instance of the Document class which represents the message body. See Chapter 17: Working with Item Bodies for more information.