Exporting An Outlook Contact Folder As A Collection Of Vcard (.vcf) Files

I recently wanted to export my contacts to individual .VCF  files for backup purposes and also have the ability to import them into other programs.  There are ways to do this for a few contacts at a time by forwarding them in email to yourself or performing File -> SaveAs operations,  but they suffer from scaling issues when you have many contacts export.

I authored this VBScript tool to export my contact folder one afternoon.  It has the ability to:

  • Dynamically select an Outlook Contacts folder to export
  • Automatically create a date-stamped folder to store the export into
  • Cycle through each contact in the selected folder, generate a file name, and then save each contact as a .VCF (vcard)

This program operates as an Outlook Macro.  The instructions on how to enable and execute macros in Outlook is not easy for new programmers, but I provided basic steps below.

  • In Outlook’s “Tell Me What You Want To Do” prompt type:  Macros
  • Select Macros and during the subsequent pop-up, “Enable Macros”.  You only have to do this once per session.
  • Type Macros again in the search bar and select:  Macros
  • In the Macros pop-up, type the name:  ExportContactsToVCF, and then select:  “Create”
  • In the pop-up editor, copy and paste the entire code snippet below and replace all existing text in the VBScript editor
  • To immediately test, select the “>” green arrow in the VBScript editor
  • Alternately, type:  Macros, once again and select the newly-created:  ExportContactsToVCF, macro to execute that macro at a later date
  • Check out:  C:\OutlookContactsExport\[computername]\YYYYMMDD, to view your exported contacts
'# -----------------------------------------------------------------------
'# https://docs.microsoft.com/en-us/office/vba/api/outlook.contactitem
'# Author: Eric L. Edberg 2019-10-31
'# Select and export Outlook Contacts Folder to .VCF files
'# -----------------------------------------------------------------------

Public Sub ExportContactsToVCF()
Dim ExportFolder As String
Dim YYYYMMDD As String
Dim strHostName As String
Dim objFSO

Const max = 1000
Const min = 1
Const olFolderContacts = 10
Const olVCard = 6

Set fso = CreateObject("Scripting.FileSystemObject")
Randomize

ExportFolder = "C:\OutlookContactsExport"
If Len(Dir(ExportFolder, vbDirectory)) = 0 Then
MkDir ExportFolder
End If

strHostName = Environ$("computername")
ExportFolder = "C:\OutlookContactsExport\" & strHostName
If Len(Dir(ExportFolder, vbDirectory)) = 0 Then
MkDir ExportFolder
End If

YYYYMMDD = Format(Date, "yyyymmdd")
ExportFolder = "C:\OutlookContactsExport\" & strHostName & "\" & YYYYMMDD
If Len(Dir(ExportFolder, vbDirectory)) = 0 Then
MkDir ExportFolder
End If

MsgBox "Exporting Outlook Contacts as .VCF files into folder: " & ExportFolder

MsgBox "During the next pop-up prompt, select the Outlook Contacts folder that you wish to export as .VCF contacts"
Set objContacts = Application.GetNamespace("MAPI").PickFolder

MsgBox "The next step will export your contacts. It may take awhile and Outlook will appear to hang (lock up) during this process. It may take a minute or 3 to complete depending on the number of contacts you have to export"

On Error Resume Next

ErrorCnt = 0
OkCnt = 0
Err = 0
DupCnt = 0
For cnt = 1 To objContacts.Items.Count
strName2 = objContacts.Items(cnt).LastName & objContacts.Items(cnt).FirstName
strName = objContacts.Items(cnt).FileAs
If strName = "" Or IsNull(strName) Then
strName = objContacts.Items(cnt).CompanyName
End If

'# ToDo: Is there a function to make a string filename safe?
strName = Replace(Replace(Replace(strName, "(", "-"), ")", "-"), "*", "-")
strName = Replace(Replace(Replace(strName, "&", "-"), " ", "-"), "*", "-")
strName = Replace(Replace(Replace(strName, "/", "-"), "\", "-"), ":", "-")

strPath = ExportFolder & "\" & strName & ".vcf"

'# 
If (fso.FileExists(strPath)) Then
xRI = (Int((max - min + 1) * Rnd + min))
strPath = ExportFolder & "\" & strName & "-" & xRI & ".vcf"
DupCnt = DupCnt + 1
'# MsgBox "Contact already exported: Saving duplicate with random postfix: " & strName & "-" & xRI & ".vcf"
End If

Err = 0
objContacts.Items(cnt).SaveAs strPath, olVCard

If Err Then
ErrorCnt = ErrorCnt + 1
Else
OkCnt = OkCnt + 1
End If

Next

On Error GoTo 0

MsgBox "COMPLETED exported (" & OkCnt & ") contacts, with (" & DupCnt & ") duplicates, with (" & ErrorCnt & ") errors, folder: " & ExportFolder

End Sub