I wanted to grab the photos (“ContactPicture”) that people put in their Outlook Contact Details.
Not sure if I grabbed this code from somewhere, or wrote it myself. Just leaving it here for the next time I need it.
Note to self:
* you need a local copy of the address book to run this code against.
Sub SaveContactPhoto()
Dim itemContact As ContactItem
Dim fdrContacts As MAPIFolder
Dim colAttachments As Outlook.Items
Dim colItems As Outlook.Items
Dim fname As String
'Default Contacts folder
'Set fdrContacts = Session.GetDefaultFolder(olFolderContacts)
' Selected folder
' Ensure you select the GAL folder ....
Set fdrContacts = Application.ActiveExplorer.CurrentFolder
On Error Resume Next
For itemCounter = 1 To fdrContacts.Items.Count
Set itemContact = fdrContacts.Items(itemCounter)
Set collAttachments = itemContact.Attachments
For Each attach In collAttachments
If attach.FileName = "ContactPicture.jpg" Then
fname = (itemContact.FirstName & " " & itemContact.LastName & ".jpg")
If fname <> "" Then
attach.SaveAsFile ("C:\data\Contact Photos\" & fname)
End If
End If
Next
Next
End Sub
Bonus fact: Microsoft call the Outlook Contact Details “Profile Cards”
