Attribute VB_Name = "Contacts"
Option Explicit

Private Destination As String

Public Sub Main()

    Destination = "C:\Documents and Settings\Administrator\Desktop"
    ExportContacts
    
End Sub

Public Sub ExportContacts()

    Dim O As Outlook.Application: Set O = ThisOutlookSession
    Dim NS As NameSpace: Set NS = O.Session
    
    'find contacts folder
    Dim Contacts As MAPIFolder: Set Contacts = NS.GetDefaultFolder(olFolderContacts)
    
    'get root folder (in case there are multiple contact-type folders)
    Dim Mailbox As MAPIFolder: Set Mailbox = Contacts.Parent
    
    Dim Folder As MAPIFolder
    For Each Folder In Mailbox.Folders
        ExportFolder Folder
    Next
    
End Sub

Public Sub ExportFolder(Folder As MAPIFolder)
    On Error GoTo MemberError
    
    'Debug.Print Folder.FolderPath
    
    'folder must be a folder that holds contacts
    If Not Folder.DefaultItemType = olContactItem Then Exit Sub
    
    Dim Path As String
    Path = Destination & "\" & Right(Folder.FolderPath, Len(Folder.FolderPath) - InStr(3, Folder.FolderPath, "\"))
    
    CreateFolder Path
    
    Dim Item As Object
    For Each Item In Folder.Items
        If Item.Class = olContact Then
        
            'save as vCard
            Item.SaveAs Path & "\" & Item.Subject & ".vcf", olVCard
            
        End If
    Next

    Dim Subfolder As MAPIFolder
    For Each Subfolder In Folder.Folders
        ExportFolder Subfolder
    Next

MemberExit:
    On Error GoTo 0
    Exit Sub
    
MemberError:
    Select Case Err.Number
    Case Else
        MsgBox Err.Description, vbExclamation, "Export Contacts"
        Resume MemberExit
    End Select
    
End Sub

Private Sub CreateFolder(Path As String)

    Dim FSO As New FileSystemObject
    If Not FSO.FolderExists(Path) Then FSO.CreateFolder Path
    Set FSO = Nothing
    
End Sub