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

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("ag@joinreal.com")
    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