Include extraction of additional info

The code here will extract emails from to cc as well as the body of the email.

I want expand the code to include any info such as a name that might have been part of the email address.

Assistance is greatly appreciated.

http://www.codeshare.io/VLR1a
frugalmuleAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

MacroShadowCommented:
I don't understand.
0
frugalmuleAuthor Commented:
Sometimes an email to or cc field will have a name next to the address.
0
David Johnson, CD, MVPOwnerCommented:
Set xlApp = CreateObject("Excel.Application")     xlApp not defined is his error

  Dim NS As Outlook.NameSpace
    Dim pickedfolder As Object
    Dim counter As Long, i As Long
    Dim arr, Item

    Set NS = Application.GetNamespace("MAPI")
    Set pickedfolder = NS.pickfolder
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets("Sheet1")

    xlApp.Visible = True

    counter = 1
    For Each Item In pickedfolder.Items
        If Item.SenderEmailType = "SMTP" Then
            xlSheet.Cells(counter, 1).Value = Item.SenderEmailAddress
            If Item.CC <> "" Then
                xlSheet.Cells(counter, 2).Value = Item.CC
            End If
            If Item.Body <> "" Then
                arr = ExtractEmailAddresses(Item.Body)
                For i = LBound(arr) To UBound(arr)
                    xlSheet.Cells(counter, 2).Offset(, i + 1).Value = arr(i)
                Next
            End If
            counter = counter + 1
        End If
    Next

End Sub

Public Function ExtractEmailAddresses(strBody As String) As Variant

    Dim objMatch As Object
    Dim arrMatches()
    Dim lngCount As Long

    arrMatches = Array()

    With CreateObject("VBScript.RegExp")
        .MultiLine = True
        .IgnoreCase = True
        .Global = True
        .Pattern = "\w+([-+.']\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*"
        For Each objMatch In .Execute(strBody)
            ReDim Preserve arrMatches(lngCount)
            arrMatches(lngCount) = objMatch.Value
            lngCount = lngCount + 1
        Next
    End With

    ExtractEmailAddresses = arrMatches

End Function

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

frugalmuleAuthor Commented:
Can you explain?
0
MacroShadowCommented:
What he means is, Option Explicit forces declaring variables and xlApp, xlBook and xlSheet are not declared.
He thought your question was that you get compile errors.
0
KimputerCommented:
The only extra thing you can do is replace:

xlSheet.Cells(counter, 1).Value = Item.SenderEmailAddress

Open in new window


with

xlSheet.Cells(counter, 1).Value = """" & Item.SenderName & """ <" & Item.SenderEmailAddress & ">"

Open in new window


For the body, except for advanced A.I. coupled with a supercomputer, you can't really match the sender's name in a logical manner (unless the body is made in a fixed logical format and not written by a human).
0
frugalmuleAuthor Commented:
Sounds good, will try
Dim NS As Outlook.NameSpace
    Dim pickedfolder As Object
    Dim counter As Long, i As Long
    Dim arr, Item

    Set NS = Application.GetNamespace("MAPI")
    Set pickedfolder = NS.pickfolder
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets("Sheet1")

    xlApp.Visible = True

    counter = 1
    For Each Item In pickedfolder.Items
        If Item.SenderEmailType = "SMTP" Then
            xlSheet.Cells(counter, 1).Value = """" & Item.SenderName & """ <" & Item.SenderEmailAddress & ">"
            If Item.CC <> "" Then
                xlSheet.Cells(counter, 2).Value = Item.CC
            End If
            If Item.Body <> "" Then
                arr = ExtractEmailAddresses(Item.Body)
                For i = LBound(arr) To UBound(arr)
                    xlSheet.Cells(counter, 2).Offset(, i + 1).Value = arr(i)
                Next
            End If
            counter = counter + 1
        End If
    Next

End Sub

Public Function ExtractEmailAddresses(strBody As String) As Variant

    Dim objMatch As Object
    Dim arrMatches()
    Dim lngCount As Long

    arrMatches = Array()

    With CreateObject("VBScript.RegExp")
        .MultiLine = True
        .IgnoreCase = True
        .Global = True
        .Pattern = "\w+([-+.']\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*"
        For Each objMatch In .Execute(strBody)
            ReDim Preserve arrMatches(lngCount)
            arrMatches(lngCount) = objMatch.Value
            lngCount = lngCount + 1
        Next
    End With

    ExtractEmailAddresses = arrMatches

End Function

Open in new window

0
frugalmuleAuthor Commented:
Macros enabled but window comes empty and does not show the macro.

This video further illustrates the steps I took http://screencast.com/t/ZQUarnQtC.
0
David Johnson, CD, MVPOwnerCommented:
follow the instructions as you didn't copy this line
Sub pickfolder()

my sorta working codeyour nonworking code
'USE - To extract email addresses from IMAP folders in Microsoft Outlook (2013) including the to and cc fields as well as the message body.
'It "should" work for ALL Outlook folder types including IMAP, PST, OST, and Microsoft Exchange type folders.

'AUTHOR - EE Kimputer, EE MacroShadow
'DATE - May 9, 2015

'FROM WITHIN OUTLOOK:
'TO OPEN CODE EDITOR - Press ALT+F11 to open the code editor, and paste the code into the "ThisOutlookSession" module.
'To CALL SCRIPT - Press ALT+F8 to select the macro, then follow the prompts to select the folder(s) that you want to extract email addresses from.

'IN PROGRESS - Include any info such as a name that might have been part of the email address extrated and remove duplicates if possible.

'Option Explicit

Sub pickfolder()
Dim NS As Outlook.NameSpace
    Dim pickedfolder As Object
    Dim counter As Long, i As Long
    Dim arr, Item

    Set NS = Application.GetNamespace("MAPI")
    Set pickedfolder = NS.pickfolder
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets("Sheet1")

    xlApp.Visible = True

    counter = 1
    For Each Item In pickedfolder.Items
        If Item.SenderEmailType = "SMTP" Then
           xlSheet.Cells(counter, 1).Value = """" & Item.SenderName & """ <" & Item.SenderEmailAddress & ">"
            If Item.CC <> "" Then
                xlSheet.Cells(counter, 2).Value = Item.CC
            End If
            If Item.Body <> "" Then
                arr = ExtractEmailAddresses(Item.Body)
                For i = LBound(arr) To UBound(arr)
                    xlSheet.Cells(counter, 2).Offset(, i + 1).Value = arr(i)
                Next
            End If
            counter = counter + 1
        End If
    Next

End Sub

Public Function ExtractEmailAddresses(strBody As String) As Variant

    Dim objMatch As Object
    Dim arrMatches()
    Dim lngCount As Long

    arrMatches = Array()

    With CreateObject("VBScript.RegExp")
        .MultiLine = True
        .IgnoreCase = True
        .Global = True
        .Pattern = "\w+([-+.']\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*"
        For Each objMatch In .Execute(strBody)
            ReDim Preserve arrMatches(lngCount)
            arrMatches(lngCount) = objMatch.Value
            lngCount = lngCount + 1
        Next
    End With

    ExtractEmailAddresses = arrMatches

End Function

Open in new window

0
frugalmuleAuthor Commented:
Ah, ok

Thank you!!
0
frugalmuleAuthor Commented:
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.