Extract text string from undeliverable email body to Excel

Question

I am trying to extract the email address from each individual undeliverables email body.

The email body would be like:

----------------------------Email----------------------------

Delivery has failed to these recipients or groups:

[email protected] ([email protected])

...no need info...

To: [email protected]

...no need info...

----------------------------Email-----------------------------

I came up with below code:

Sub Test()
   Dim myFolder As MAPIFolder
   Dim Item As Outlook.MailItem 'MailItem
   Dim xlApp As Object 'Excel.Application
   Dim xlWB As Object 'Excel.Workbook
   Dim xlSheet As Object 'Excel.Worksheet
   Dim Lines() As String
   Dim i As Integer, x As Integer, P As Integer
   Dim myItem As Variant
   Dim subjectOfEmail As String
   Dim bodyOfEmail As String

'Try access to excel
   On Error Resume Next
   Set xlApp = GetObject(, "Excel.Application")
   If xlApp Is Nothing Then
     Set xlApp = CreateObject("Excel.Application")
     xlApp.Application.Visible = True
     If xlApp Is Nothing Then
       MsgBox "Excel is not accessable"
       Exit Sub
     End If
   End If
   On Error GoTo 0

 'Add a new workbook
   Set xlWB = xlApp.Workbooks.Add
   xlApp.Application.Visible = True
   Set xlSheet = xlWB.ActiveSheet
   Set myFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
   For Each myItem In myFolder.Items
     subjectOfEmail = myItem.Subject
     bodyOfEmail = myItem.Body

 'Search for Undeliverable email
     If bodyOfEmail Like "*Delivery*" & "*failed*" And indexOfEmail Like "*Undeliverable*" Then
       x = x + 1
 'Extract email address from email body
       Lines = Split(myItem.Body, vbCrLf)
       For i = 0 To UBound(Lines)
         P = InStr(1, Lines(i), "@", vbTextCompare)
         Q = InStr(1, Lines(i), "(", vbTextCompare)
         If P > 0 Then
           xlApp.Range("A" & x) = Trim$(Mid$(Lines(i), 1, Q - 1)) 'extract the email address
           Exit For
         End If
       Next
    End If
  Next
End Sub

It worked on my test Email Inbox, which opened an Excel sheet and listed every particular email address within the target emails.

When I ran this code on my work email account, it didn't give me a thing. I found that it had trouble reading "Undeliverables" emails, and every time after I ran it, one of the undeliverables emails turned into Traditional Chinese characters which cannot be read.

格浴㹬格慥㹤਍洼瑥⁡瑨灴攭畱癩∽潃瑮湥⵴祔数•潣瑮湥㵴琢硥⽴瑨汭※档牡敳㵴獵愭捳楩㸢⼼敨摡㰾潢祤ാ㰊㹰戼㰾潦瑮挠汯牯∽〣〰㘰∶猠穩㵥㌢•慦散∽牁慩≬䐾汥癩牥⁹慨⁳慦汩摥琠桴獥⁥敲楣楰湥獴漠⁲牧畯獰㰺是湯㹴⼼㹢⼼㹰਍昼湯⁴潣潬

I feel this code works on only forwarded undeliverable email, in my test email inbox.
It never read from the original undeliverable emails and turned those emails to Chinese characters one by one.

I googled it, it seems there are bugs in Outlook for the failed delivery emails. How to fix this?

Answer 1

After frustrated several days, I finally came up a much simpler solution, which doesn't need to worry about any restriction of NDR in Outlook or even never use VBA at all...

What I did is:

1. Select all the non-delivery emails in Outlook
2. Save as a ".txt" file
3. Open Excel, open the txt file and select "Delimited" and select "Tab" as delimiter in the "Text Import Wizard"
4. filter out the column A with "To:", then will get all the email address on column B

Can't believe this is much simpler than VBA...

Thank you guys for your help! Just can't really deal with the "Outlook NDR turning to unreadable characters" bug with so many restrictions on a work station, think this might be helpful!

Answer 2

For getting addresses... I can pull the address from the action.reply which creates an outlook message with a body and sender:

Sub Addressess_GET_for_all_selected()
   Dim objSel As Selection
   Dim i As Integer
   Dim objMail As MailItem
   Dim objRept As ReportItem
    Dim oa As Recipient
    Dim strStr As String
    Dim objAct As Action

   Set objSel = Outlook.ActiveExplorer.Selection

    Dim colAddrs As New Collection

    On Error GoTo 0
    frmProgress.SetMax (objSel.Count)
    'On Error Resume Next 'GoTo Set_Domains_Mail_Collection_ERR

    On Error GoTo SkipObj: ''for unhandled types
    For i = 1 To objSel.Count

      Set objMail = Nothing

      If objSel(i).Class = olReport Then    ''report email addresses 2020-02-12
         Set objRept = Nothing
         Set objRept = objSel(i)

         For Each objAct In objRept.Actions
            If objAct.Name = "Reply" Then
               Set objMail = objAct.Execute
               Exit For
            End If
         Next objAct
      End If

      ''fire on objmail or if is omail
      If objSel(i).Class = olMail Then
            Set objMail = objSel(i)
      End If

      If Not objMail Is Nothing Then
            DoEvents
            For Each oa In objMail.Recipients
                colAddrs.Add GetSMTPAddress(oa.Address)
            Next oa
            On Error Resume Next '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                colAddrs.Add GetSMTPAddress(objMail.sender.Address)
            On Error GoTo 0 '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
            objMail.Delete
      End If

SkipObj:
        frmProgress.SetCurrent (i)
    Next i

    SortDedupCollection_PUSH colAddrs
    frmProgress.Hide
End Sub

And GET SMTP:

Private Function GetSMTPAddress(ByVal strAddress As String) As String
' As supplied by Vikas Verma ... see
' http://blogs.msdn.com/vikas/archive/2007/10/24/oom-getting-primary-smtp-address-from-x400-x500-sip-ccmail-etc.aspx
Dim olApp As Object
Dim oCon As Object
Dim strKey As String
Dim oRec As Recipient ' Object
Dim strRet As String
Dim fldr As Object
    'IF OUTLOOK VERSION IS >= 2007 THEN USES NATIVE OOM PROPERTIES AND METHODS
    On Error Resume Next

    If InStr(1, strAddress, "@", vbTextCompare) <> 0 Then
        GetSMTPAddress = strAddress
        Exit Function
    End If

    Set olApp = Application
    Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Item("Random")
    If fldr Is Nothing Then
        olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Add "Random"
        Set fldr = olApp.GetNamespace("MAPI").GetDefaultFolder(10).Folders.Item("Random")
    End If
    On Error GoTo 0
    If CInt(Left(olApp.VERSION, 2)) >= 12 Then
        Set oRec = olApp.Session.CreateRecipient(strAddress)
        If oRec.Resolve Then
            On Error Resume Next
            strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
            If strRet = "" Then
                strRet = Split(oRec.AddressEntry.Name, "(")(2) ''at least provide name.
                strRet = Left(strRet, InStr(1, strRet, ")") - 1)
            End If
            On Error GoTo 0
        End If
    End If
    If Not strRet = "" Then GoTo ReturnValue
    'IF OUTLOOK VERSION IS < 2007 THEN USES LITTLE HACK
    'How it works
    '============
    '1) It will create a new contact item
    '2) Set it's email address to the value passed by you, it could be X500,X400 or any type of email address stored in the AD
    '3) We will assign a random key to this contact item and save it in its Fullname to search it later
    '4) Next we will save it to local contacts folder
    '5) Outlook will try to resolve the email address & make AD call if required else take the Primary SMTP address from its cache and append it to Display name
    '6) The display name will be something like this " ( [email protected] )"
    '7) Now we need to parse the Display name and delete the contact from contacts folder
    '8) Once the contact is deleted it will go to Deleted Items folder, after searching the contact using the unique random key generated in step 3
    '9) We then need to delete it from Deleted Items folder as well, to clean all the traces
    Set oCon = fldr.items.Add(2)
    oCon.Email1Address = strAddress
    strKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
    oCon.FullName = strKey
    oCon.Save
    strRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(", ""), ")", ""), strKey, ""))
    oCon.Delete
    Set oCon = Nothing
    Set oCon = olApp.Session.GetDefaultFolder(3).items.Find("[Subject]=" & strKey)
    If Not oCon Is Nothing Then oCon.Delete
ReturnValue:
    GetSMTPAddress = strRet
End Function

Answer 3

sI have been having exactly the same issue. All of the NDR messages I am dealing with are of the class "REPORT.IPM.Note.NDR" and the method I found for obtaining the original recipient was pieced together from a number of these sorts of posts and questions that I've been trawling through!

I am using the PropertyAccessor.GetProperty method against the ReportItem to obtain the PR_DISPLAY_TO property value from the header information of the ReportItem.

In VBA, I am using the MAPI namepace and looping through the olItems collection of a given folder containing the report messages. I'm running this from Access as my database front-end is built that way, but I would imagine you can probably run it from within Outlook VBA (but don't hold me to that).

Dim olApp As Outlook.Application
Dim OlMapi As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Outlook.ReportItem
Dim OlItems As Outlook.Items

Set olApp = CreateObject("Outlook.Application")
Set OlMapi = olApp.GetNamespace("MAPI")
Set olFolder = OlMapi.Folders("SMTP-ADDRESS-FOR-YOUR-MAILBOX").Folders("Inbox").Folders("NAME-OF-SUBFOLDER_CONTAINING-NDR-REPORTS")
Set OlItems = olFolder.Items

If OlItem.Count > 0 Then
    For Each olMail In OlItems
        strEmail = olMail.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E04001E")
        'DO WITH strEmail AS REQUIRED   
        DoEvents
    Next
End If

The returned value from that MAPI property could be a semicolon delimited list where there are multiple recipients, so you could check for ';' in the returned string and then split into an array and iterate through to get each individual address, but in my case, there is only ever one recipient so I didn't need to over complicate it. It also may be a display name when the original recipient is a contact, so this may be a shortcoming for some, but again in my case, that's not a factor.

This is just a snippet of a bigger function so you will need to amend and integrate it to your needs, and obviously replace or amend the placeholders for the mailbox and subfolder values.

The intention is currently to also extract the NDR reason code so that I can automate removal of email addresses from our database where the reason is because the mailbox does not exist, so referring only to ReportItem object - This likely won't work for NDR emails which are not of that type, as I would image thoe MAPI properties are not available, however I have found in practice that all of the NDR messages come back like this as we are using Exchange Online.

Answer 4

I Did some tweaking to the original code in the first post, and added a helper function to Extract Email From String, and seems to be working fine.

Sub List_Undeliverable_Email_To_Excel()
    Dim myFolder As MAPIFolder
    Dim Item As Outlook.MailItem 'MailItem
    Dim xlApp As Object 'Excel.Application
    Dim xlWB As Object 'Excel.Workbook
    Dim xlSheet As Object 'Excel.Worksheet
    Dim Lines() As String
    Dim i As Integer, x As Integer, P As Integer
    Dim myItem As Variant
    Dim subjectOfEmail As String
    Dim bodyOfEmail As String
    
    'Try access to excel
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If xlApp Is Nothing Then
        Set xlApp = CreateObject("Excel.Application")
        xlApp.Application.Visible = True
        If xlApp Is Nothing Then
            MsgBox "Excel is not accessable"
            Exit Sub
        End If
    End If
    On Error GoTo 0
    
    'Add a new workbook
    Set xlWB = xlApp.Workbooks.Add
    xlApp.Application.Visible = True
    Set xlSheet = xlWB.ActiveSheet
    Set myFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Real Estate").Folders("[email protected]")
    For Each myItem In myFolder.Items
        subjectOfEmail = myItem.Subject
        bodyOfEmail = myItem.Body
    
        'Search for Undeliverable email
        If subjectOfEmail Like "*Undeliverable*" Or subjectOfEmail Like "*Undelivered*" Or subjectOfEmail Like "*Failure*" And subjectOfEmail Like "*Delivery*" Then   'bodyOfEmail Like "*Deliver*" And
            x = x + 1
            'Extract email address from email body
            Lines = Split(bodyOfEmail, vbCrLf)
            For i = 0 To UBound(Lines)
                P = InStr(1, Lines(i), "@", vbTextCompare)
                If P > 0 Then
                    EmailAdd = ExtractEmailFromString(Lines(i), True)
                    Debug.Print x & " " & EmailAdd
                    xlApp.Range("A" & x) = EmailAdd
                    Exit For
                End If
            Next
        End If
    Next
End Sub

Function ExtractEmailFromString(extractStr As String, Optional OnlyFirst As Boolean) As String
    Dim CharList As String
    On Error Resume Next
    CheckStr = "[A-Za-z0-9._-]"
    OutStr = ""
    Index = 1
    Do While True
        Index1 = VBA.InStr(Index, extractStr, "@")
        getStr = ""
        If Index1 > 0 Then
            For P = Index1 - 1 To 1 Step -1
                If Mid(extractStr, P, 1) Like CheckStr Then
                    getStr = Mid(extractStr, P, 1) & getStr
                Else
                    Exit For
                End If
            Next
            getStr = getStr & "@"
            For P = Index1 + 1 To Len(extractStr)
                If Mid(extractStr, P, 1) Like CheckStr Then
                    getStr = getStr & Mid(extractStr, P, 1)
                Else
                    Exit For
                End If
            Next
            Index = Index1 + 1
            If OutStr = "" Then
                OutStr = getStr
                If OnlyFirst = True Then GoTo E
            Else
                OutStr = OutStr & Chr(10) & getStr
            End If
        Else
            Exit Do
        End If
    Loop
E:
    ExtractEmailFromString = OutStr
End Function

Answer 5

There is a problem with the ReportItem.Body property in the Outlook Object Model (present in Outlook 2013 and 2016) - you can see it in OutlookSpy (I am its author): select an NDR message, click Item button, select the Body property - it will be garbled. Worse than that, once the report item is touched with OOM, Outlook will display the same junk in the preview pane.

The report text is stored in various MAPI recipient properties (click IMessage button in OutlookSpy and go to the GetRecipientTable tab). The problem is the ReportItem object does not expose the Recipients collection. The workaround is to either use Extended MAPI (C++ or Delphi) or Redemption (I am its author - any language) - its RDOReportItem.ReportText property does not have this problem:

set oItem = Application.ActiveExplorer.Selection(1)
set oSession = CreateObject("Redemption.RDOSession")
oSession.MAPIOBJECT = Application.Session.MAPIOBJECT
set rItem = oSession.GetRDOObjectFromOutlookObject(oItem)
MsgBox rItem.ReportText

You can also use RDOReportItem.Recipients collection to extract various NDR properties from the recipient table.