How do I extract the email adress from this text string?

dcharland

New Member
Joined
Mar 2, 2011
Messages
40
Hello,

I'm writing some code to extract an email address, so far I was able to separate the body of the email into individual line. But would need some guidance with how to extract the email (if one is found in the string). In some other instances the email will be in the "from" field, but I'm assuming that the code will be re-usable?

The string would look something like this:
HTML:
  Your message did not reach some or all of the intended recipients.
   
        Subject:    Information Meeting - Networking for Career Opportunity
        Sent: 07/03/2011 11:43 AM
   
  The following recipient(s) cannot be reached:
   
        'csdi@chaumontsystems.com' on 07/03/2011 11:46 AM
              550 5.3.4 Requested action not taken; To continue sending messages, please sign in to your account.
And here is the code I have so far:

HTML:
For Each MItem In MySubFolder.Items
'MsgBox Ebody
If Left(MItem.Subject, 13) = "Undeliverable" Then ' If the first 14 characters from the subject are "Undeliverable"
Status = "Undeliverable"
Ebody = Split(MItem.body, vbLf)
X = 0 'each line in the body was split, this x will loop through the Ebody sub-strings
' look for email in each sub-string
'*** This is where I have no ideas ******
Thanks
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,434
Here's an example of one way it could be done...

Code:
Sub Example_emails()


    MItem = "  Your message did not reach some or all of the intended recipients." & vbLf & vbLf & _
            " Subject:    Information Meeting - Networking for Career Opportunity " & vbLf & _
            " Sent: 07/03/2011 11:43 AM " & vbLf & vbLf & _
            " The following recipient(s) cannot be reached: " & vbLf & vbLf & _
            " [COLOR="Red"]'csdi@chaumontsystems.com'[/COLOR] on 07/03/2011 11:46 AM " & vbLf & _
            " 550 5.3.4 Requested action not taken; To continue [COLOR="Red"]Sombody@anotheremail.com[/COLOR] sending messages, please sign in to your account. "
    
    If InStr(MItem, "@") Then  [COLOR="Green"]' If MItem contains an @ character[/COLOR]
        
        [COLOR="Green"]' Split each word in MItem[/COLOR]
        EWords = Split(MItem)
        
        [COLOR="Green"]' Display each word that contains @[/COLOR]
        For i = LBound(EWords) To UBound(EWords)
            If InStr(EWords(i), "@") Then MsgBox EWords(i)
        Next i

    Else
        MsgBox "No Emails found."
    End If
    
End Sub
 

dcharland

New Member
Joined
Mar 2, 2011
Messages
40
Hi AlphaFrog,

The code work perfectly when used in a sub just as you wrote it, but I'm having troubles incorporating it into my code because I have used the Ebody =Split(MItem.body, vblf) line which puts the split strings in Ebody(x) but VBA want's me to declare Ebody as an object, which I can't because it's not...well i don't think so?

So how should I "loop" through each of the different lines of text if I have them in a variant variable Ebody?

Thanks again
 

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,434

ADVERTISEMENT

Why are you splitting them by lines (vbLF)? Why not just split them by words (spaces).

Ebody =Split(MItem.body)

The space character is the default delimiter.

If you really want to loop through the lines...
Code:
For i = LBound(EBody) to UBound(EBody)

      EWords = Split(EBody(i))
      ' Do something with EWords

Next i
 
Last edited:

dcharland

New Member
Joined
Mar 2, 2011
Messages
40
Hi AlphaFrog,

The only reason for splitting in sentences was that I didn't know that we could achieve it by words (default) thanks for the info. I got the code to work. But I don't know if its the same for programmers, (i'm not one), but each time I get something to work, there is something else that doesn't!!!

Just in case you know the answer and want to share it: In my "returned" emails some actually attached the original email to them and the code also extracts the emails addresses from those attachments, is there a way that we could ignore these attachments.

There are also some email addresses that aren't cleanned up properly for example it returns the following "mailto:info@bradsys.com"info@bradsys.comthe" is there a way to fix this and various other possible combination (lenght of string). Perhaps if there isn't I will simply not move the email (as the email address will not match any others in the spreadsheet) and the user will need to set the status manually in the spreadsheet.

thanks for your precious help.

denis
 

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,434

ADVERTISEMENT

... but each time I get something to work, there is something else that doesn't!!!
It happens to all of us. Parsing text is not too hard, but it can be tricky or tedious. There always seems to be a new situation you have to account for.

Just in case you know the answer and want to share it: In my "returned" emails some actually attached the original email to them and the code also extracts the emails addresses from those attachments, is there a way that we could ignore these attachments.
I don't understand this.

"mailto:info@bradsys.com"info@bradsys.comthe" is there a way to fix this and various other possible combination (lenght of string).

This will clean up some things like "mailto:info@bradsys.com"info@bradsys.comthe" but you may have to add additional cleaning code for other situations.
Code:
Sub Cleanup_Example()

    OriginalWord = "mailto:info@bradsys.com""info@bradsys.comthe"
    Eword = OriginalWord
    
    Eword = Replace(Eword, "mailto:", "")   ' Strip Mailto:
    Eword = Replace(Eword, "'", "")         ' Strip single quotes (not needed in this example)
    Eword = Trim(Replace(Eword, """", " ")) ' Strip double quotes (replace with a space so it can be split again
    Temp = Split(Eword)                     ' Split double email address now separated by a space
    Eword = Temp(LBound(Temp))              ' Remember only 1st address
    
    MsgBox OriginalWord & vbCr & vbCr & "Is now cleaned up: " & vbCr & Eword
    
End Sub
 

dcharland

New Member
Joined
Mar 2, 2011
Messages
40
Thanks for your numerous responses :) Really helpful.

What I meant was:

In the case where I get a "Delivery Status Notification (Failure)" this email also contains my original email attached to it. The code i'm using extracts email addresses from the attached (original email)

In other words, I would like to have the code only extract emails from the "Delivery Status Notification (Failure)" email and not go into the attached email. I'm assuming that.....as i'm writing this I realized that my code must be wrong as I have a condition to only look at emails with "Undeliverable"???? And even if it does that would not be found in column "D" anyway's ( I think)

I intend to add a series of else if to account for the various "subject" of the emails as this will set different value for the Status to be written in colunm "J"

Do you see anything wrong with this code?

HTML:
For Each MItem In MySubFolder.Items
    'MsgBox Ebody
    If Left(MItem.Subject, 13) = "Undeliverable" Then ' If the first 13 characters from the subject are "Undeliverable"
        Status = "Undeliverable"
        If InStr(MItem.body, "@") Then  ' If MItem.body contains an @ character
        
        ' Split each word in MItem.body
        Ewords = Split(MItem.body)
        
        ' Display each word that contains @
        For i = LBound(Ewords) To UBound(Ewords)
            If InStr(Ewords(i), "@") Then
            'compare Ewords(i)email will the ones in column "D"
                For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants)
                    If Ewords(i) = Cells(cell.row, "D").Value Then Cells(cell.row, "J").Value = Status: MsgBox "found match"
                    
                Next cell
                
            Else
            End If
           'MsgBox Ewords(i)
          
        Next i
   
    Else
        MsgBox "No Emails found."
    End If
 

dcharland

New Member
Joined
Mar 2, 2011
Messages
40
Hi,

Since yesterday I decided to change the logic of the program and thus, the new code looks like this. Any comments from experience programmers would be greatly appreciated (so i can learn) otherwise hope it will help some other newbie like me.

HTML:
Sub SetStatus()
Dim OutApp As Object ' ****'Outlook.Application
Dim NmSpace As Object ' ** 'Outlook.NameSpace
Dim Inbox As Object ' **** 'Outlook.MAPIFolder
Dim MItem As Object ' **** 'Outlook.MailItem
Dim MySubFolder As Object
Dim i As Long
Dim Response As String
Dim BodyArray() As Variant
Dim EmailAddress As String
Dim Ebody As Variant
Dim Ewords As Variant
Dim Status As String
Dim Cell As Range
Dim ProcessedFolder As Object
Dim MartchFound As String


Set OutApp = CreateObject("Outlook.Application")
Set NmSpace = OutApp.GetNamespace("MAPI")
Set Inbox = NmSpace.GetDefaultFolder(6) 'olFolderInbox
Set MySubFolder = Inbox.Folders("test") ' Note Case Sensitive!
Set ProcessedFolder = Inbox.Folders("processed") ' Note Case Sensitive!

'look in the body of the email for email address
For Each MItem In MySubFolder.Items
     'look at subject to set the satus
    Status = "Other" ' This is the default if no condition have been meet or email cleaning failed
    If Left(MItem.Subject, 13) = "Undeliverable" Then Status = "Undeliverable" ': MsgBox Status & vbLf & Cell.row & vbLf & EmailClean
    If Left(MItem.Subject, 4) = "Read" Then Status = "Read" ': MsgBox Status & vbLf & Cell.row & vbLf & EmailClean
    If Left(MItem.Subject, 8) = "Not Read" Then Status = "Deleted" ': MsgBox Status & vbLf & Cell.row & vbLf & EmailClean
    If Left(MItem.Subject, 38) = "Delivery Status Notification (Failure)" Then Status = "failed" ': MsgBox Status & vbLf & Cell.row & vbLf & EmailClean
    If Left(MItem.Subject, 36) = "Delivery Status Notification (Delay)" Then Status = "Delayed"
    If Left(MItem.Subject, 3) = "RE:" Then Status = "Replied"
    If Left(MItem.Subject, 3) = "Re:" Then Status = "Replied"
    If Left(MItem.Subject, 3) = "re:" Then Status = "Replied"
'    If Status = "Other" Then MsgBox "The email " & MItem.Subject & " ins't part of any conditions, thus we wont do anything with this email!" 'status didn't change thus no above condition where meet
    
    If InStr(MItem.body, "@") Then ' If MItem.body contains an @ character
        Ewords = Split(MItem.body) ' Split each word in MItem.body and assign it to the Ewords variable
        MatchFound = ""
   '     MsgBox "Found email addresse in Boby of " & vbLf & MItem
            For i = LBound(Ewords) To UBound(Ewords) ' sets the for i loop to the number of split in MItem
                    If InStr(Ewords(i), "@") Then 'Looking for the word that as the email address
                        CleanEmail = Ewords(i) 'passing this CleanEmail to EmailAdresCleanup sub
                       
                        Call EmailAddresCleanup ' Cleanup email address as much as possible
                            'now that I have a clean email address look for it in column "D" There are duplicated email so will need to figure out how to work with that? set status based on email subject
                            MsgBox EmailClean '
                            For Each Cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants) ' scroll thru the D column
                                '****************what to do with duplicates?******************************
                                    If EmailClean = Cells(Cell.row, "D").Value Then 'found the cell with the same email address
                                        'write status to "J" of the same row
                                        MatchFound = MatchFound + "yes"
                                        Cells(Cell.row, "J").Value = Status
                                        'this will duplicate the emails if there are duplicat email addresses.
                                        If MatchFound = "yes" And Status <> "Other" Then
                                        MItem.Move ProcessedFolder: MsgBox MItem & " was moved to " & ProcessedFolder ': MItem.Category = "Interview": MItem.Save
                                        Else
MsgBox "The email " & MItem & " " & EmailClean & " was not moved" & vbLf & Status & vbLf & MatchFound & vbLf & EmailClean & " = " & Cells(Cell.row, "D").Value & "in row " & Cell.row

                                        End If
                                    Else
                                    ' exit if and look at next cell it will flag all duplicates with the latest email states!!****************
                                    End If
            
                            Next Cell
                    Else
                    ' didn't find an "@" in the current string will look at the next string
                    End If
            Next i 'ok now i'm really going to the next string
    Else
    ' no email address in this email body moving to the next one
    MsgBox "No email address in this email " & MItem & vbLf & MItem.body
    End If
    
Next MItem 'did all I had to do with this email, lets go to the next.

GoTo cleanup 'sub done let's clean up after ourselves


cleanup:

Set MItem = Nothing
Set Inbox = Nothing
Set NmSpace = Nothing
Set OutApp = Nothing
Set MySubFolder = Nothing

End Sub
 

AlphaFrog

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,434
Code:
Sub SetStatus()

Dim OutApp As Object ' ****'Outlook.Application
Dim NmSpace As Object ' ** 'Outlook.NameSpace
Dim Inbox As Object ' **** 'Outlook.MAPIFolder
Dim MItem As Object ' **** 'Outlook.MailItem
Dim MySubFolder As Object
Dim i As Long
Dim Response As String
Dim BodyArray() As Variant
Dim EmailAddress As String
Dim Ebody As Variant
Dim Ewords As Variant
Dim Status As String
Dim Cell As Range
Dim ProcessedFolder As Object
Dim MartchFound As String


Set OutApp = CreateObject("Outlook.Application")
Set NmSpace = OutApp.GetNamespace("MAPI")
Set Inbox = NmSpace.GetDefaultFolder(6) 'olFolderInbox
Set MySubFolder = Inbox.Folders("test") ' Note Case Sensitive!
Set ProcessedFolder = Inbox.Folders("processed") ' Note Case Sensitive!

'look in the body of the email for email address
For Each MItem In MySubFolder.Items

[COLOR="Green"]     'look at subject to set the satus
''    Status = "Other" ' This is the default if no condition have been meet or email cleaning failed
''    If Left(MItem.Subject, 13) = "Undeliverable" Then Status = "Undeliverable" ': MsgBox Status & vbLf & Cell.row & vbLf & EmailClean
''    If Left(MItem.Subject, 4) = "Read" Then Status = "Read" ': MsgBox Status & vbLf & Cell.row & vbLf & EmailClean
''    If Left(MItem.Subject, 8) = "Not Read" Then Status = "Deleted" ': MsgBox Status & vbLf & Cell.row & vbLf & EmailClean
''    If Left(MItem.Subject, 38) = "Delivery Status Notification (Failure)" Then Status = "failed" ': MsgBox Status & vbLf & Cell.row & vbLf & EmailClean
''    If Left(MItem.Subject, 36) = "Delivery Status Notification (Delay)" Then Status = "Delayed"
''    If Left(MItem.Subject, 3) = "RE:" Then Status = "Replied"
''    If Left(MItem.Subject, 3) = "Re:" Then Status = "Replied"
''    If Left(MItem.Subject, 3) = "re:" Then Status = "Replied"[/COLOR]

[COLOR="Red"]    Select Case True
        Case Left(MItem.Subject, 13) = "Undeliverable": Status = "Undeliverable"
        Case Left(MItem.Subject, 4) = "Read": Status = "Read"
        Case Left(MItem.Subject, 8) = "Not Read": Status = "Deleted"
        Case InStr(MItem.Subject, "(Failure)"): Status = "failed"
        Case InStr(MItem.Subject, "(Delay)"): Status = "Delayed"
        Case UCase(Left(MItem.Subject, 3)) = "RE:": Status = "Replied"
        Case Else: Status = "Other"
    End Select[/COLOR]

    ' If Status = "Other" Then MsgBox "The email " & MItem.Subject & " ins't part of any conditions, thus we wont do anything with this email!" 'status didn't change thus no above condition where meet
    
    If InStr(MItem.body, "@") Then ' If MItem.body contains an @ character
        Ewords = Split(MItem.body) ' Split each word in MItem.body and assign it to the Ewords variable
        MatchFound = ""
        ' MsgBox "Found email addresse in Boby of " & vbLf & MItem
            For i = LBound(Ewords) To UBound(Ewords) ' sets the for i loop to the number of split in MItem
                    If InStr(Ewords(i), "@") Then 'Looking for the word that as the email address
[COLOR="Green"]''                        CleanEmail = Ewords(i) 'passing this CleanEmail to EmailAdresCleanup sub
''                        Call EmailAddresCleanup ' Cleanup email address as much as possible[/COLOR]
[COLOR="Red"]                          CleanEmail = EmailAddressCleanup(Ewords(i))    'EmailAddressCleanup as a function[/COLOR]
                          
                            'now that I have a clean email address look for it in column "D" There are duplicated email so will need to figure out how to work with that? set status based on email subject
                            [COLOR="Green"]' MsgBox EmailClean '[/COLOR]
                            [COLOR="Red"]MsgBox CleanEmail[/COLOR]
                            
[COLOR="Green"]''                            For Each Cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants) ' scroll thru the D column
''                                '****************what to do with duplicates?******************************
''                                    If EmailClean = Cell.Value Then 'found the cell with the same email address
''                                        'write status to "J" of the same row
''                                        MatchFound = MatchFound + "yes"
''                                        Cells(Cell.Row, "J").Value = Status
''
''                                        'this will duplicate the emails if there are duplicat email addresses.
''                                        If MatchFound = "yes" And Status <> "Other" Then
''                                            MItem.Move ProcessedFolder: MsgBox MItem & " was moved to " & ProcessedFolder ': MItem.Category = "Interview": MItem.Save
''                                        Else
''                                            MsgBox "The email " & MItem & " " & EmailClean & _
''                                                   " was not moved" & vbLf & Status & vbLf & _
''                                                   MatchFound & vbLf & EmailClean & " = " & _
''                                                   Cells(Cell.Row, "D").Value & "in row " & Cell.Row
''                                        End If
''
''                                    Else
''                                    ' exit if and look at next cell it will flag all duplicates with the latest email states!!****************
''                                    End If
''
''                            Next Cell[/COLOR]

[COLOR="Red"]                            Dim Found As Range, FirstFound As String
                            
                            ' The .Find method is faster at finding a cell match than looping through each cell
                            Set Found = Columns("D").Find(What:=EmailClean, _
                                                          LookAt:=xlWhole, _
                                                          SearchOrder:=xlByRows, _
                                                          SearchDirection:=xlNext, _
                                                          MatchCase:=False)
                                                          
                            If Not Found Is Nothing Then    ' Test if a Match was found
                                FirstFound = Found.Address  ' Remember first match address to stop the loop later
                                Do
                                    Found.Offset(, 6).Value = Status    ' Put Status in column J
                                    If Status <> "Other" Then
                                        MItem.Move ProcessedFolder: MsgBox MItem & " was moved to " & ProcessedFolder ': MItem.Category = "Interview": MItem.Save
                                    Else
                                        MsgBox "The email " & MItem & " " & EmailClean & _
                                               " was not moved" & vbLf & Status & vbLf & _
                                               "yes" & vbLf & EmailClean & " = " & _
                                               Found.Value & " in row " & Found.Row
                                    End If
                                    
                                    Set Found = Columns("D").FindNext(After:=Found)
                                    
                                Loop Until Found.Address = FirstFound   'Loop until the first match is found again
                             End If[/COLOR]
                        
                    Else
                    ' didn't find an "@" in the current string will look at the next string
                    End If
            Next i 'ok now i'm really going to the next string
    Else
    ' no email address in this email body moving to the next one
        MsgBox "No email address in this email " & MItem & vbLf & MItem.body
    End If
    
Next MItem 'did all I had to do with this email, lets go to the next.

'' GoTo cleanup 'sub done let's clean up after ourselves
cleanup:

    Set MItem = Nothing
    Set Inbox = Nothing
    Set NmSpace = Nothing
    Set OutApp = Nothing
    Set MySubFolder = Nothing

End Sub

Code:
[COLOR="Red"]Private Function EmailAddressCleanup(ByVal str As String) As String
    ' cleanup str here
    EmailAddresCleanup = str
End Function[/COLOR]
 

Forum statistics

Threads
1,144,369
Messages
5,723,952
Members
422,528
Latest member
IMK

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top