Insert Photo to Contact

[LMS]

And I forgot to ask ......before I changed the code so it only goes to the selected contact, it add the photo to all Contacts in the default folder...as I have many many contacts in the default folder......is there simple code that removes the picture form each selected contacts....as that would be much faster as well...

 

[LMS]

I just figured out how to change the code we use so it removes the Picture...here is the code if that helps others

Public Sub UpdateContactPhoto2()
Dim myOlApp As outlook.Application
Dim myNamespace As outlook.NameSpace
Dim myContacts As Selection
Dim myItems As outlook.Items
Dim myItem As Object
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myContacts = Application.ActiveExplorer.Selection

Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
For Each myItem In myContacts
If (myItem.Class = olContact) Then
Dim myContact As outlook.contactItem
Set myContact = myItem

Dim strPhoto As String

myContact.RemovePicture
myContact.Save
End If

Next
End Sub

 

[LMS]

I also have ask right away as we did the same for another code and I can' t remember exactly what we did.

In the past we had codes that worked when we select or open a contact, but if we open the contact from the email we received there was something else to add to the code, so the code worked as to contact that was opened up from the email received and not from the contact folder. So here is the full code we know have for the photo and it works for the selected contacts or open contact, but not if the contact is opened from the email received....so please tell me again what I need to adjust so it works when the contact is opened from the email received and not from the contact folder.

Public Sub AddPhoto()
Dim myOlApp As outlook.Application
Dim myNamespace As outlook.NameSpace
Dim myContacts As Selection
Dim myItems As outlook.Items
Dim myItem As Object
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myContacts = Application.ActiveExplorer.Selection

Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
For Each myItem In myContacts
If (myItem.Class = olContact) Then
Dim myContact As outlook.contactItem
Set myContact = myItem

Dim strPhoto As String

' use myContact.LastNameAndFirstName = "last, first.jpg" format
' replace "C:\photos\" with the correct path.
strPhoto = "C:\Users\UserName\Pictures\NewPhotoName.jpg"

' use for testing only, to confirm the path is correct.
' Delete or comment out
' MsgBox (strPhoto)


If fs.FileExists(strPhoto) Then
myContact.AddPicture strPhoto
myContact.Save
End If
End If
Next
End Sub

 

[LMS]

To All if This Helps:

The following code adds the photo to the contact when I open the contact, select the contact, open the contact from an email I received...and of course if there are parts of it that don't need to been in there, I don't know what to take out, as I found the standard code I was given before to do it both ways, and just added to it the photo process.

Sub AddPhoto()
Dim objApp As Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim objItem As Object
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
On Error Resume Next
If TypeName(objApp.ActiveWindow) = "Inspector" Then
Set objItem = objApp.ActiveInspector.currentItem
strPhoto = "C:\Users\UserNaem\Pictures\NewPhotoName.jpg"
If fs.FileExists(strPhoto) Then
objItem.AddPicture strPhoto
objItem.Save
End If
GoTo Leave
End If
Set objSelection = objApp.ActiveExplorer.Selection
For Each objItem In objSelection
strPhoto = "C:\Users\UserName\Pictures\NewPhotoName.jpg"
If fs.FileExists(strPhoto) Then
objItem.AddPicture strPhoto
objItem.Save
End If
objItem.Save
Next
Leave:
Set objItem = Nothing
Set objFolder = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub