I have pasted the following code into an Outlook 2010 module and it works perfectly apart from I want it to extract every bounced back email address in a "Failed Delivery" Email not just the first one within the email. Postmaster mail failure emails report in multiples of failed email addresses within one email not just one. I read somewhere that it involves adding an element called MyRegExp Global property to TRUE. But unfortunately my VBA coding skills are limited. Would value anyones help immensely.

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 = False
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

Function checkEmail(ByVal Body As String) As Boolean
Dim keywords(29) As String
keywords(0) = "Delivery to the following recipients failed"
keywords(1) = "user unknown"
keywords(2) = "The e-mail account does not exist"
keywords(3) = "undeliverable address"
keywords(4) = "550 Host unknown"
keywords(5) = "No such user"
keywords(6) = "Addressee unknown"
keywords(7) = "Mailaddress is administratively disabled"
keywords(8) = "unknown or invalid"
keywords(9) = "Recipient address rejected"
keywords(10) = "disabled or discontinued"
keywords(11) = "Recipient verification failed"
keywords(12) = "no mailbox here by that name"
keywords(13) = "This user doesn't have a yahoo.com account"
keywords(14) = "No mailbox found"
keywords(15) = "not our customer"
keywords(16) = "mailbox unavailable"
keywords(17) = "Mailbox disabled"
keywords(18) = "mailbox is inactive"
keywords(19) = "address error"
keywords(20) = "unknown recipient"
keywords(21) = "unknown user"
keywords(22) = "mail to the recipient is not accepted on this system"
keywords(23) = "no user with that name"
keywords(24) = "invalid recipient"
keywords(25) = “message could not be delivered”
keywords(26) = “Host or domain name not found”
keywords(27) = “Connection timed out”
keywords(28) = “The following recipient(s) could not be reached”

'Default value
checkEmail = False
For Each word In keywords
If InStr(1, Body, word, vbTextCompare) > 1 Then
checkEmail = True
Exit For
End If
Next word
End Function

Thanking you very much, in advance.
WiltsBoy