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?
 
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
 
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
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.

All Courses

From novice to tech pro — start learning today.