bagullo
02-25-2015, 09:06 AM
hi,
I'd like to export contact pictures, but apparently when it does so it does using "my contacts" and these only have contact picture if I have "added to outlook contacts" first from a global address book of my work environment.
is there anyway to do that by vba ?
12914
this is what I use to export contact pictures
maybe can be tuned to export from global address book??
'2015-01-08 / B.Agullo /
Sub SaveContactPhoto()
'does not work with global addressbook configuration...
Dim itemContact As ContactItem
Dim fdrContacts As MAPIFolder
Dim colAttachments As Outlook.Items
Dim colItems As Outlook.Items
Dim DATAr As Range
Dim picPath As String
Dim fname As String
Set fdrContacts = Session.GetDefaultFolder(olFolderContacts)
On Error Resume Next
For itemCounter = 1 To fdrContacts.Items.Count
Set itemContact = fdrContacts.Items(itemCounter)
Set DATAr = getRow(DATA.Range("c_user"), itemContact.Account)
If Not DATAr Is Nothing Then
Set collAttachments = itemContact.Attachments
For Each Attach In collAttachments
If Attach.filename = "ContactPicture.jpg" Then
fname = (itemContact.FirstName & itemContact.LastName & ".jpg")
picPath = thisworkbook.path & "\Outlook Pictures\" & fname
Attach.SaveAsFile (picPath)
DATAr.Range("Picture") = picPath
End If
Next
End If
Next
End Sub
I'd like to export contact pictures, but apparently when it does so it does using "my contacts" and these only have contact picture if I have "added to outlook contacts" first from a global address book of my work environment.
is there anyway to do that by vba ?
12914
this is what I use to export contact pictures
maybe can be tuned to export from global address book??
'2015-01-08 / B.Agullo /
Sub SaveContactPhoto()
'does not work with global addressbook configuration...
Dim itemContact As ContactItem
Dim fdrContacts As MAPIFolder
Dim colAttachments As Outlook.Items
Dim colItems As Outlook.Items
Dim DATAr As Range
Dim picPath As String
Dim fname As String
Set fdrContacts = Session.GetDefaultFolder(olFolderContacts)
On Error Resume Next
For itemCounter = 1 To fdrContacts.Items.Count
Set itemContact = fdrContacts.Items(itemCounter)
Set DATAr = getRow(DATA.Range("c_user"), itemContact.Account)
If Not DATAr Is Nothing Then
Set collAttachments = itemContact.Attachments
For Each Attach In collAttachments
If Attach.filename = "ContactPicture.jpg" Then
fname = (itemContact.FirstName & itemContact.LastName & ".jpg")
picPath = thisworkbook.path & "\Outlook Pictures\" & fname
Attach.SaveAsFile (picPath)
DATAr.Range("Picture") = picPath
End If
Next
End If
Next
End Sub