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”

Related posts:

So Outlook 2003 and 2007 store the email account details there. Microsoft commits to releasing Outlook PST format "This advertised application will not be installed because it might be unsafe. Contact your administrator …"

Powered by YARPP.