Microsoft Office Forums - View Single Post - [Solved] How do I extract all my email addresses into one file?

gmayor · 05-16-2015, 04:32 AM

Based largely on Sue Mosher's code at http://www.outlookcode.com/d/code/autoaddrecip.htm, the following macro will add the sender's of each e-mail in the selected Outlook folder to the Outlook contacts list.

Although aimed at Word, the VBA editor in Outlook is virtually identical to that shown in the tutorial at http://www.gmayor.com/installing_macro.htm

Code:

Option Explicit

Sub AddFolderToContacts()
Dim olFolder As Folder
Dim olExpl As Explorer
Dim olItem As MailItem
    Set olExpl = ActiveExplorer
    If Not olExpl Is Nothing Then
        Set olFolder = olExpl.CurrentFolder
        For Each olItem In olFolder.Items
            MsgBox olItem.Sender
            AddEmailToContacts olItem
        Next olItem
    End If
lbl_Exit:
    Set olItem = Nothing
    Set olExpl = Nothing
    Set olFolder = Nothing
    Exit Sub
End Sub

Sub AddEmailToContacts(objMail As Outlook.MailItem)
Dim strFind As String
Dim strAddress As String
Dim objNS As Outlook.NameSpace
Dim colContacts As Outlook.Items
Dim objContact As Outlook.ContactItem

Dim i As Integer
    On Error Resume Next

    ' get Contacts folder and its Items collection
    Set objNS = Application.GetNamespace("MAPI")
    Set colContacts = _
    objNS.GetDefaultFolder(olFolderContacts).Items

    ' process message recipients
    ' check to see if the recip is already in Contacts
    strAddress = objMail.SenderEmailAddress
    For i = 1 To 3
        strFind = "[Email" & i & "Address] = " & _
                  strAddress
        Set objContact = colContacts.Find(strFind)
        If Not objContact Is Nothing Then
            Exit For
        End If
    Next i

    ' if not, add it
    If objContact Is Nothing Then
        Set objContact = _
        Application.CreateItem(olContactItem)
        With objContact
            .FullName = objMail.SenderName
            .Email1Address = strAddress
            .Save
        End With
    End If
    Set objContact = Nothing

lbl_Exit:
    Set objNS = Nothing
    Set objContact = Nothing
    Set colContacts = Nothing
    Exit Sub
End Sub