Expand code to extract more email address from Outlook imap folder

The code here https://kobra.io/#/e/-JowTiigV4iANjxEQDhf is designed to extract emails from an Outlook imap folder.  Unfortunately, it does not extract from the cc field or from the body of the emails.  Assistance in adding this to the code is greatly appreciated.
frugalmuleAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
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:
Please try this:
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.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
frugalmuleAuthor Commented:
Hi,

This says macros are disabled but it ran last time.

Does this code remove from the to, cc, as well as the body?
Does it care whether the folders are imap, ost, or pst?

Can it remove duplicates on it's own?
0
MacroShadowCommented:
This says macros are disabled but it ran last time.
Read this article: http://www.experts-exchange.com/articles/10805/Overcome-the-Trust-Center-nuisance.html

Does this code remove from the to, cc, as well as the body?
It extracts emails from: cc and body in addition to what the original code did, as per your question.

Does it care whether the folders are imap, ost, or pst?
It is just like the original code, only amended to extract from the cc and body.

Can it remove duplicates on it's own?
The as is doesn't remove duplicates as it wasn't a requirement in your question. It can be added but should be asked in a new question.
0
frugalmuleAuthor Commented:
Sure will.  Is it just imap or will it work with any type of Outlook mail folder?
0
MacroShadowCommented:
Should work for all, I think...
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
VB Script

From novice to tech pro — start learning today.