Microsoft Office Forums - View Single Post - Macro

gmayor · 09-25-2020, 12:02 AM

There is no VBA recorder in Outlook, however the following will do what you require. You may have to add or remove fields to fit your brief, but the principles remain the same.

Code:

Sub ExportContactsToExcel()
Dim olItem As Outlook.ContactItem
Dim rCount As Long
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim fso As Object
Dim Fileout As Object
Const strPath As String = "C:\Path\OutlookContacts.csv"        'the path of the csv"

    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "No Items selected!", vbCritical, "Error"
        Exit Sub
    End If
    
    sText = Chr(34) & "FirstName" & Chr(34)
    sText = sText & Chr(44) & Chr(34) & "LastName" & Chr(34)
    sText = sText & Chr(44) & Chr(34) & "CompanyName" & Chr(34)
    sText = sText & Chr(44) & Chr(34) & "Street" & Chr(34)
    sText = sText & Chr(44) & Chr(34) & "City" & Chr(34)
    sText = sText & Chr(44) & Chr(34) & "State" & Chr(34)
    sText = sText & Chr(44) & Chr(34) & "PostalCode" & Chr(34)
    sText = sText & Chr(44) & Chr(34) & "POBoxNum" & Chr(34)
    sText = sText & Chr(44) & Chr(34) & "Country" & Chr(34)
    sText = sText & Chr(44) & Chr(34) & "EMail" & Chr(34)
    sText = sText & Chr(44) & Chr(34) & "BusinessPhone" & Chr(34)
    sText = sText & Chr(44) & Chr(34) & "HomePhone" & Chr(34)
    sText = sText & Chr(44) & Chr(34) & "MobilePhone" & Chr(34)

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Fileout = fso.CreateTextFile(strPath, True, True)
    Fileout.WriteLine sText

    For Each olItem In Application.ActiveExplorer.Selection
        If olItem.Email1Address <> "" Then
            sText = Chr(34) & Trim(olItem.FirstName) & Chr(34)
            sText = sText & Chr(44) & Chr(34) & Trim(olItem.LastName) & Chr(34)
            sText = sText & Chr(44) & Chr(34) & Trim(olItem.CompanyName) & Chr(34)
            sText = sText & Chr(44) & Chr(34) & Trim(olItem.MailingAddressStreet) & Chr(34)
            sText = sText & Chr(44) & Chr(34) & Trim(olItem.MailingAddressCity) & Chr(34)
            sText = sText & Chr(44) & Chr(34) & Trim(olItem.MailingAddressState) & Chr(34)
            sText = sText & Chr(44) & Chr(34) & Trim(olItem.MailingAddressPostalCode) & Chr(34)
            sText = sText & Chr(44) & Chr(34) & Trim(olItem.MailingAddressPostOfficeBox) & Chr(34)
            sText = sText & Chr(44) & Chr(34) & Trim(olItem.MailingAddressCountry) & Chr(34)
            sText = sText & Chr(44) & Chr(34) & Trim(olItem.Email1Address) & Chr(34)
            sText = sText & Chr(44) & Chr(34) & Trim(olItem.BusinessTelephoneNumber) & Chr(34)
            sText = sText & Chr(44) & Chr(34) & Trim(olItem.HomeTelephoneNumber) & Chr(34)
            sText = sText & Chr(44) & Chr(34) & Trim(olItem.MobileTelephoneNumber) & Chr(34)
            Fileout.WriteLine sText
        End If
        DoEvents
    Next olItem
    Fileout.Close
lbl_Exit:
    Set olItem = Nothing
    Set fso = Nothing
    Set Fileout = Nothing
    Exit Sub
End Sub