Extract text string from undeliverable email body to excel

Question

I need some help on Outlook VBA.

I am trying to write a macro in Outlook for extracting the email address from each individual undeliverables email body.

Th

Answer 1

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.address@server.com )"
    '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