ovari1How to export Microsoft Outlook Contacts as vCard (.vcf text) files and contact photos as JPEG (.jpeg) image files
https://www.extendoffice.com/documents/outlook/5286-export-outlook-contacts-with-photos.html
The below VBA code can help you to export all contacts in a specific Contacts folder to separate text files with contact photos.
- Select a Contacts folder which you want to export the contacts with photos.
- And then, hold down the ALT + F11 keys to open the Microsoft Visual Basic for Applications window.
- Then, click Insert > Module, copy and paste below code into the opened blank module, see screenshot:
VBA code to export Microsoft Outlook Contacts as .vcf and .jpeg files
- Please update this page with any missing fields, eg webpages.
- If you know how to export images as base64, please let us know as then the vcf file can include the contact photo.
- Setting the IMPP type problematic in CardBook 60.2. Any help in improving the code is welcomed.
- File names are just numbers as saving files with the name of the contact may produce errors when names contain non-ASCII characters.
- Microsoft Office unfortunately saves in a type of Unicode (but not UTF-8).
- Files are named as only numbers (
number.vcfandnumber.jpeg) so exporting of non-ASCII contacts will work without causing problems.
Sub BatchExportContactPhotosandInformation()
' Adapted from https://www.extendoffice.com/documents/outlook/5286-export-outlook-contacts-with-photos.html
' Tools -> References… -> Microsoft XML, v6.0 (or 3.0)
' Tested with:
' Linux Mint 20.2 Cinnamon beta https://www.linuxmint.com/
' WineHQ 6.11 https://www.winehq.org/
' PlayOnLinux 4.3.4 https://www.playonlinux.com/
' Microsoft Office 2010
' Thunderbird 78.11.0 https://www.thunderbird.net/
' CardBook 60.2 https://addons.thunderbird.net/addon/cardbook/
Dim xContactItems As Outlook.Items
Dim xItem As Object
Dim xContactItem As ContactItem
Dim xContactInfo As String
Dim xShell As Object
Dim xFSO As Scripting.FileSystemObject
Dim xTextFile As Scripting.TextStream
Dim xAttachments As Attachments
Dim xAttachment As Attachment
Dim xSavePath, xEmailAddress As String
Dim xFolder As Outlook.Folder
Dim intItem As Integer
Dim strPref As String
'On Error Resume Next
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xShell = CreateObject("Shell.application").BrowseforFolder(0, "Select a Folder", 0, 16)
If xShell Is Nothing Then Exit Sub
xSavePath = xShell.Items.Item.Path & "\"
xLinuxSavePath = xSavePath
xLinuxSavePath = Replace(xLinuxSavePath, "C:\users\", "/home/")
xLinuxSavePath = Replace(xLinuxSavePath, "\", "/")
If Outlook.Application.ActiveExplorer.CurrentFolder.DefaultItemType <> olContactItem Then
Set xFolder = Outlook.Application.Session.GetDefaultFolder(olFolderContacts)
Else
Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder
End If
Set xContactItems = xFolder.Items
For I = xContactItems.Count To 1 Step -1
Set xItem = xContactItems.Item(I)
If xItem.Class = olContact Then
Set xContactItem = xItem
With xContactItem
intItem = 0
' BEGIN and VERSION are required names
xContactInfo = "BEGIN:VCARD" & _
vbCrLf & "VERSION:4.0"
If Len(trim(.Categories)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "CATEGORIES:" & Replace(.Categories, ", ", ",")
End If
' FN is a required name
xContactInfo = xContactInfo & _
vbCrLf & "FN:" & .FileAs
If ((Len(trim(.LastName)) <> 0) Or _
(Len(trim(.FirstName)) <> 0) Or _
(Len(trim(.MiddleName)) <> 0) Or _
(Len(trim(.Title)) <> 0) Or _
(Len(trim(.Suffix)) <> 0)) Then
xContactInfo = xContactInfo & _
vbCrLf & "N:" & .LastName & ";" & .FirstName & ";" & .MiddleName & ";" & .Title & ";" & .Suffix
End If
If Len(trim(.NickName)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "NICKNAME:" & .NickName
End If
If .Birthday <> DateValue("1/01/4501") Then
xContactInfo = xContactInfo & _
vbCrLf & "BDAY:" & Format(Year(.Birthday), "0000") & Format(Month(.Birthday), "00") & Format(Day(.Birthday), "00")
End If
' Does Outlook have a BIRTH PLACE field? If so, what is it called?
If (0) Then
If Len(trim(.BIRTHPLACE)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "BIRTHPLACE:" & "Does Outlook have a BIRTH PLACE field? If so, what is it called?"
End If
End If
' Gender
' 0 Unspecified
' 1 Female
' 2 Male
Select Case .Gender
Case olUnspecified
' U = unknown
chrGender = "U"
Case olFemale
chrGender = "F"
Case olMale
chrGender = "M"
Case Else
' O = Other
chrGender = "O"
End Select
xContactInfo = xContactInfo & _
vbCrLf & "GENDER:" & chrGender
If .Anniversary <> DateValue("1/01/4501") Then
xContactInfo = xContactInfo & _
vbCrLf & "ANNIVERSARY:" & Format(Year(.Anniversary), "0000") & Format(Month(.Anniversary), "00") & Format(Day(.Anniversary), "00")
End If
' Does Outlook have a DEATH PLACE field? If so, what is it called?
If (0) Then
If Len(trim(.DEATHPLACE)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "DEATHPLACE:" & "Does Outlook have a DEATH PLACE field? If so, what is it called?"
End If
End If
If Len(trim(.JobTitle)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "TITLE:" & .JobTitle
End If
If Len(trim(.Profession)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "ROLE:" & .Profession
End If
If Len(trim(.CompanyName)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "ORG:" & .CompanyName
End If
If Len(trim(.Email1Address)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "EMAIL:" & .Email1Address
End If
If Len(trim(.Email2Address)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "EMAIL:" & .Email2Address
End If
If Len(trim(.Email3Address)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "EMAIL:" & .Email3Address
End If
If Len(trim(.AssistantTelephoneNumber)) <> 0 Then
intItem = intItem + 1
xContactInfo = xContactInfo & _
vbCrLf & "ITEM" & intItem & ".TEL:" & .AssistantTelephoneNumber & _
vbCrLf & "ITEM" & intItem & ".X-ABLABEL:" & "Assistant"
End If
If Len(trim(.BusinessTelephoneNumber)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "TEL;TYPE=WORK:" & .BusinessTelephoneNumber
End If
If Len(trim(.Business2TelephoneNumber)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "TEL;TYPE=WORK:" & .Business2TelephoneNumber
End If
If Len(trim(.BusinessFaxNumber)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "TEL;TYPE=FAX;TYPE=WORK:" & .BusinessFaxNumber
End If
If Len(trim(.CallbackTelephoneNumber)) <> 0 Then
intItem = intItem + 1
xContactInfo = xContactInfo & _
vbCrLf & "ITEM" & intItem & ".TEL:" & .CallbackTelephoneNumber & _
vbCrLf & "ITEM" & intItem & ".X-ABLABEL:" & "Callback"
End If
If Len(trim(.CarTelephoneNumber)) <> 0 Then
intItem = intItem + 1
xContactInfo = xContactInfo & _
vbCrLf & "ITEM" & intItem & ".TEL:" & .CarTelephoneNumber & _
vbCrLf & "ITEM" & intItem & ".X-ABLABEL:" & "Car"
End If
If Len(trim(.CompanyMainTelephoneNumber)) <> 0 Then
intItem = intItem + 1
xContactInfo = xContactInfo & _
vbCrLf & "ITEM" & intItem & ".TEL:" & .CompanyMainTelephoneNumber & _
vbCrLf & "ITEM" & intItem & ".X-ABLABEL:" & "Company"
End If
If Len(trim(.HomeTelephoneNumber)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "TEL;TYPE=HOME:" & .HomeTelephoneNumber
End If
If Len(trim(.Home2TelephoneNumber)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "TEL;TYPE=HOME:" & .Home2TelephoneNumber
End If
If Len(trim(.HomeFaxNumber)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "TEL;TYPE=FAX;TYPE=HOME:" & .HomeFaxNumber
End If
If Len(trim(.ISDNNumber)) <> 0 Then
intItem = intItem + 1
xContactInfo = xContactInfo & _
vbCrLf & "ITEM" & intItem & ".TEL:" & .ISDNNumber & _
vbCrLf & "ITEM" & intItem & ".X-ABLABEL:" & "ISDN"
End If
If Len(trim(.MobileTelephoneNumber)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "TEL;TYPE=CELL:" & .MobileTelephoneNumber
End If
If Len(trim(.OtherTelephoneNumber)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "TEL;TYPE=OTHER:" & .OtherTelephoneNumber
End If
If Len(trim(.OtherFaxNumber)) <> 0 Then
intItem = intItem + 1
xContactInfo = xContactInfo & _
vbCrLf & "ITEM" & intItem & ".TEL:" & .OtherFaxNumber & _
vbCrLf & "ITEM" & intItem & ".X-ABLABEL:" & "Other Fax"
End If
If Len(trim(.PagerNumber)) <> 0 Then
intItem = intItem + 1
xContactInfo = xContactInfo & _
vbCrLf & "ITEM" & intItem & ".TEL:" & .PagerNumber & _
vbCrLf & "ITEM" & intItem & ".X-ABLABEL:" & "Pager"
End If
If Len(trim(.PrimaryTelephoneNumber)) <> 0 Then
intItem = intItem + 1
xContactInfo = xContactInfo & _
vbCrLf & "ITEM" & intItem & ".TEL;PREF=1:" & .PrimaryTelephoneNumber & _
vbCrLf & "ITEM" & intItem & ".X-ABLABEL:" & "Primary"
End If
If Len(trim(.RadioTelephoneNumber)) <> 0 Then
intItem = intItem + 1
xContactInfo = xContactInfo & _
vbCrLf & "ITEM" & intItem & ".TEL:" & .RadioTelephoneNumber & _
vbCrLf & "ITEM" & intItem & ".X-ABLABEL:" & "Radio"
End If
If Len(trim(.TelexNumber)) <> 0 Then
intItem = intItem + 1
xContactInfo = xContactInfo & _
vbCrLf & "ITEM" & intItem & ".TEL:" & .TelexNumber & _
vbCrLf & "ITEM" & intItem & ".X-ABLABEL:" & "Telex"
End If
If Len(trim(.TTYTDDTelephoneNumber)) <> 0 Then
intItem = intItem + 1
xContactInfo = xContactInfo & _
vbCrLf & "ITEM" & intItem & ".TEL:" & .TTYTDDTelephoneNumber & _
vbCrLf & "ITEM" & intItem & ".X-ABLABEL:" & "TTY/TDD"
End If
If Len(trim(.BusinessAddress)) <> 0 Then
If .MailingAddress = .BusinessAddress Then
strPref = ";PREF=1"
Else
strPref = ""
End If
xContactInfo = xContactInfo & _
vbCrLf & "ADR" & strPref & ";TYPE=WORK:;;" & _
Replace(.BusinessAddressStreet, vbCrLf, "\n") & ";" & _
.BusinessAddressCity & ";" & _
.BusinessAddressState & ";" & _
.BusinessAddressPostalCode & ";" & _
.BusinessAddressCountry
End If
If Len(trim(.HomeAddress)) <> 0 Then
If .MailingAddress = .HomeAddress Then
strPref = ";PREF=1"
Else
strPref = ""
End If
xContactInfo = xContactInfo & _
vbCrLf & "ADR" & strPref & ";TYPE=HOME:;;" & _
Replace(.HomeAddressStreet, vbCrLf, "\n") & ";" & _
.HomeAddressCity & ";" & _
.HomeAddressState & ";" & _
.HomeAddressPostalCode & ";" & _
.HomeAddressCountry
End If
If Len(trim(.OtherAddress)) <> 0 Then
If .MailingAddress = .OtherAddress Then
strPref = ";PREF=1"
Else
strPref = ""
End If
intItem = intItem + 1
xContactInfo = xContactInfo & _
vbCrLf & "ITEM" & intItem & ".ADR" & strPref & ":;;" & _
Replace(.OtherAddressStreet, vbCrLf, "\n") & ";" & _
.OtherAddressCity & ";" & _
.OtherAddressState & ";" & _
.OtherAddressPostalCode & ";" & _
.OtherAddressCountry & _
vbCrLf & "ITEM" & intItem & ".X-ABLABEL:" & "Other"
End If
' Notes is the Body property of a ContactItem.
' .Body is plaintext and any formating, i.e. bold, italics, underline, font, is removed.
' Any attachments do not get exported here. Attachments get exported later.
If Len(trim(.Body)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "NOTE:" & Replace(.Body, vbCrLf, "\n")
End If
If Len(trim(.AssistantName)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "X-ASSISTANTNAME:" & .AssistantName
End If
If Len(trim(.Department)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "X-ASSISTANTNAME:" & .Department
End If
' Setting the IMPP type problematic in CardBook 58.1
If Len(trim(.IMAddress)) <> 0 Then
xContactInfo = xContactInfo & _
vbCrLf & "IMPP:" & "OL" & ":" & .IMAddress
End If
If .Attachments.Count > 0 Then
Set xAttachments = .Attachments
For Each xAttachment In xAttachments
' .Type = 6 can't be exported
If xAttachment.Type <> 6 Then
If InStr(LCase(xAttachment.FileName), "contactpicture.jpg") > 0 Then
' variable 'i' added if there are duplicate cards, or people with the same name, so no contact picture will be overwritten
xAttachment.SaveAsFile (xSavePath & I & ".jpeg")
' Unfortunately, base64 conversion does not seem to be available in Outlook 2010 References
' xContactInfo = xContactInfo & _
vbCrLf & "PHOTO:data:image/jpeg;base64," & _
Base64Encode(xSavePath & I & ".jpg")
' GNU/Linux
xContactInfo = xContactInfo & _
vbCrLf & "PHOTO;VALUE=URI:file:////" & _
xLinuxSavePath & I & ".jpeg"
' Windows - has not been tested
' xContactInfo = xContactInfo & _
vbCrLf & "PHOTO;VALUE=URI:file:////" & _
xSavePath & I & ".jpeg"
Else
' EEE (Embrace, Extend, Extinguish) of allowing attachments in OL Contacts. Need to check if any contact has attachments and export them
' so there is _less_ data loss in the conversion process.
' Files start with "000_Attach_" so they should be at the beginning of the directory/folder when sorted alphabetically.
xAttachment.SaveAsFile (xSavePath & "000_Attach_" & I & "_" & xAttachment.FileName)
End If
End If
Next
End If
' END is a required name
xContactInfo = xContactInfo & _
vbCrLf & "END:VCARD"
' variable 'i' added if there are duplicate cards, or people with the same name, multiple .vcf files will be created
' The Unicode format is UCS-2LE. The files will need to be converted to UTF-8 as any other format is illegal for vCard 4.0
Set xTextFile = xFSO.CreateTextFile(xSavePath & I & ".vcf", True, True)
xTextFile.WriteLine xContactInfo
End With
End If
Next I
End Sub
- After pasting the code into the module, go on clicking Tools > References in the Microsoft Visual Basic for Applications window, in the popped out References-Project1 dialog box, check Microsoft Scripting Runtime (For Microsoft Outlook 2010, replace Microsoft Scripting Runtime with Scripting) option from the Available References list box, see screenshot:
- Click OK to close the dialog, and then press F5 key to run this code, in the popped out Browse For Folder dialog box, specify a folder where you want to output the exported contacts, see screenshot:
- Then click OK, all information with the photos of the contacts have been exported to your specific folder separately, see screenshot:
Windows Script 5.7 for Windows XP
How to convert Unicode format UCS-2LE to UTF-8
UTF-8 is the only legal encoding for vCard 4.0. The bash language and iconv for encoding conversion can be used for to change all the vcf files.
- Copy the code below into a text editor.
#!/bin/bash
#enter input encoding here
#FROM_ENCODING="value_here"
FROM_ENCODING="UCS-2LE"
#output encoding(UTF-8)
TO_ENCODING="UTF-8"
#convert
CONVERT=" iconv -f $FROM_ENCODING -t $TO_ENCODING"
#loop to convert multiple files
for file in *.vcf; do
$CONVERT "$file" -o "utf8.${file%}"
done
exit 0- In the directory where the vCard files reside, save the script file as
encoding.sh - Make the following script file executable:
encoding.sh - Open the Terminal in the directory where the vCard files and the script-file resides
- In the Terminal type:
sh encoding.sh - If you would like to rename the
utf8.*files, you can use the Bulky
How to import vCard (.vcf text) files from Outlook Contacts with photos into the CardBook Thunderbird add-on
- Install Mozilla Thunderbird, the free and open-source personal information manager
https://www.thunderbird.net/ - Open Thunderbird and install the CardBook add-on. CardBook version 60.1 or later required.
https://addons.thunderbird.net/addon/cardbook/ - Open the CardBook tab
- Right-click and select “New Address Book”
- Address book location: Local
- Type: Create a new address book
- vCard: 4.0
- Click on the address book you just created
- In the status bar in the bottom right, double-click on “Number of contacts: 0”. The CardBook “Log Viewer” window will open. Click on “Clear List”. Close the “Log Viewer”
- Right-click on the address book and select “Import Contacts from a Directory”
- Open the “Log Viewer” and to check for any errors.
Congratulations!
How to create vCard (.vcf) files with ‘base64’ contact photos
- Right-click on the address book and select “Export to a Directory”. Choose a backup directory. Check the “Log Viewer” for any errors. You now have all your contacts as vCard (.vcf text) files with the contact photos in base64.
Congratulations!
Share the word and help others move to free and open-source software for their Contacts with the CardBook add-on for Thunderbird.
https://gitlab.com/CardBook/CardBook#features