Export Contacts to CSV

Attribute VB_Name = "ExportContactsToCSV"
Option Explicit

Public Sub ExportContactsToCSV()
    Dim olApp As Object, olNs As Object, olFolder As Object, olItem As Object
    Dim csvPath As String
    Dim fileNum As Integer
    Dim count As Long

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")

    Set olNs = olApp.GetNamespace("MAPI")
    Set olFolder = olNs.GetDefaultFolder(10) ' olFolderContacts

    csvPath = Environ("USERPROFILE") & "\Desktop\Contacts_" & Format(Now, "yyyymmdd-hhnnss") & ".csv"
    fileNum = FreeFile
    Open csvPath For Output As #fileNum
    Print #fileNum, "Name,Email,Company,Phone"

    count = 0
    For Each olItem In olFolder.Items
        If olItem.Class = 40 Then ' olContact
            Print #fileNum, """" & olItem.FullName & """,""" & olItem.Email1Address & _
                """,""" & olItem.CompanyName & """,""" & olItem.BusinessTelephoneNumber & """"
            count = count + 1
        End If
    Next olItem

    Close #fileNum
    MsgBox count & " contact(s) exported to:" & vbCrLf & csvPath, vbInformation
End Sub