Search Outlook Undeliverable Bounce Report

Question

I have undeliverable emails in a folder. I am trying to pull out the intended recipient's email address by searching the message.

I have some VBA code that works on regular emails, but undeliverable's are Outlook "Report Items". The search function is coming back empty and after a lot of research, it seems "Report Items" do not have a "body" that can be searched.

The email address in all the error reports are in the format:

([email protected])

Code which works on mail items.

Sub Undeliver()

On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("MAPI")
 
'Selects the current active folder to use
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder

'creates excel spreadsheet where data will go
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add

'names column a row 1 "email" and column b row 1 "else"
xlobj.Range("a" & 1).Value = "Email"
xlobj.Range("b" & 1).Value = "Else"

'loops through all the items in the current folder selected
For I = 1 To myfolder.Items.Count
    Set myitem = myfolder.Items(I)

    'selects the body of the current email being searched
    msgtext = myitem.Body

    'searches the body for the first open parentheses and first close
    'parentheses and copies the value in between into an array
    delimtedMessage = Replace(msgtext, "(", "###")
    delimtedMessage = Replace(delimtedMessage, ")", "###")

    'splits the array up into two pieces
    messageArray = Split(delimitedMessage, "###")
    
    'this inputs the values of the array into my excel spreadsheet
    xlobj.Range("a" & I + 1).Value = messageArray(1)
    xlobj.Range("b" & I + 1).Value = messageArray(2)
Next I

End Sub

How can I access the message part of the report for searching purposes?

Answer 1

The solution I ended up going with involved converting the body of the message back to Unicode and then searching for what I needed. This ended up being very simple to implement.

Here is my finished, working code for future reference. I ended up adding a progress bar to monitor where it was in the code. It unfortunately runs fairly slow but it gets the job done.

Hopefully this helps someone in the future!

On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("MAPI")

Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add

xlobj.Range("a" & 1).Value = "Email"
xlobj.Application.displayStatusBar = True

For I = 1 To myOlApp.ActiveExplorer.CurrentFolder.Items.Count
    Set myitem = myOlApp.ActiveExplorer.CurrentFolder.Items(I)
    msgtext = StrConv(myitem.Body, vbUnicode)

    delimtedMessage = Replace(msgtext, "mailto:", "###")
    delimtedMessage = Replace(delimtedMessage, "</a><br>", "###")
    messageArray = Split(delimtedMessage, "###")

    xlobj.Range("a" & I + 1).Value = Split(messageArray(1), """")(0)
    xlobj.Application.StatusBar = "Progress: " & I & " of " & myOlApp.ActiveExplorer.CurrentFolder.Items.Count & Format(I / myOlApp.ActiveExplorer.CurrentFolder.Items.Count, " 0%")
Next I

xlobj.Application.displayStatusBar = False