• Home
 · 
• Custom Controls/Forms/Menus
 · 
• This short piece of code will loop through all your Microsoft Outlook folders and export all contac

This short piece of code will loop through all your Microsoft Outlook folders and export all contac

This short piece of code will loop through all your Microsoft Outlook folders and export all contacts as VCF files. Also will create a CSV

API Declarations


Dim I, J As Integer
Dim OLApp As Outlook.Application
Dim OLNS As Outlook.NameSpace
Dim OLFolders As Outlook.Folders
Dim OLFolder1 As Outlook.MAPIFolder
Dim OLFolder2 As Outlook.MAPIFolder
Dim OLContact As Outlook.ContactItem
Dim FSO As Scripting.FileSystemObject



Rate This short piece of code will loop through all your Microsoft Outlook folders and export all contac

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

Set FSO = CreateObject("Scripting.FileSystemObject")
Set OLApp = New Outlook.Application
Set OLNS = OLApp.GetNamespace("MAPI")
Set OLFolders = OLNS.Folders

'CREATE DATA FOLDER IF DOESN'T ALREADY EXIST
If FSO.FolderExists(App.Path & "\Data") = False Then FSO.CreateFolder App.Path & "\Data"

'LOOP THROUGH ALL FOLDERS IN OUTLOOK AND EXPORT ALL CONTACTS
Open App.Path & "\Data\_Contacts.csv" For Output As #1
Print #1, "First Name, Last Name, Company, Job Title, Business Phone, Mobile Phone, Home Phone, Other Phone, Email Address 1, Email Address2"
For Each OLFolder1 In OLFolders
    For I = 1 To OLFolder1.Folders.Count
        Set OLFolder2 = OLFolder1.Folders(I)
        If OLFolder2.DefaultItemType = olContactItem Then
            For J = 1 To OLFolder2.Items.Count
                Set OLContact = OLFolder2.Items(J)
                With OLContact
                Print #1, .FirstName & "," & .LastName & "," & .CompanyName & "," & .JobTitle & "," & .BusinessTelephoneNumber & "," & .MobileTelephoneNumber & "," & .HomeTelephoneNumber & "," & .OtherTelephoneNumber & "," & .Email1Address & "," & .Email2Address
                If .LastName = "" Then
                    OLContact.SaveAs App.Path & "\Data\" & .FirstName & ".vcf", olVCard
                Else
                    OLContact.SaveAs App.Path & "\Data\" & .FirstName & " " & .LastName & ".vcf", olVCard
                End If
                
                End With
            Next
        End If
    Next
Next
Close #1
End Sub