' Downloaded from http://www.denverdavis.com
' Written by Brian Davis

Attribute VB_Name = "ExportVcard"
Const XPortPath As String = "C:\Temp\Contacts\" 'target location on your iPod or
                                                'on a local disk to copy over
Const ext As String = ".vcf" 'file extension needed for iPod to read the vCard

Sub ExportToVCard()
Dim ns As NameSpace
Dim fld As MAPIFolder
Dim itm
Dim itms As Items

Set ns = Application.GetNamespace("MAPI")
Set fld = ns.GetDefaultFolder(olFolderContacts) 'Outlook Contacts folder
Set itms = fld.Items
itms.Sort "[LastName]", False
' The following code is the loop that builds your code
For Each itm In itms
If TypeName(itm) = "ContactItem" Then
    Dim filename
    If (itm.LastNameAndFirstName = "") Then
        filename = itm.CompanyName
    Else
        filename = itm.LastNameAndFirstName
    End If
    Debug.Print filename
    itm.SaveAs XPortPath & filename & ext, olVCard
End If
Next itm

End Sub