Update Outlook Contact from Access

Dear Experts

I have a piece of code for my Access 2003 database that looks up a contact in Outlook 2003 and if they dont exist (the criteria being where "[Profession] = 'OverpaidDirector'") then it adds a new contact.  At present if the contact exists it returns a message box stating XXXXXXXXXXXXXXX  What I would like to do is for the code to take the contact its found and then update various fields (i.e. CompanyName = "Success")

Can anyone supply a piece of code / adapt this one to do that

Many thanks

The code I have is this

Private Sub Command256_Click()
    Dim objApp As Object
    Dim objNamespace As Object
    Dim oF As Object
    Dim objContacts As Object
    Const olFolderContacts = 10
    Const olContactItem = 2
   
    Set objApp = CreateObject("Outlook.Application")
    Set objNamespace = objApp.GetNamespace("MAPI")
    Set oF = objNamespace.GetDefaultFolder(olFolderContacts)
   
    Set objContacts = oF.items.Find("[Profession] = 'OverpaidDirector'")
    If Not TypeName(objContacts) = "Nothing" Then
    MsgBox " XXXXXXXXXXXXXXX "
    Else
        'Create new item if not found
        Set objContacts = objApp.CreateItem(olContactItem)
    End If
        objContacts.Profession = "OverpaidDirector"
        objContacts.FirstName = "BBB"
        objContacts.LastName = "AAAA"
        objContacts.Email1Address = "Email@Addr.com"
        objContacts.Title = "Mr"
        objContacts.CompanyName = "Company"
        objContacts.BusinessTelephoneNumber = "OfficePhone"
        objContacts.MobileTelephoneNumber = "MobilePhone"
        objContacts.BusinessAddressCity = "BusCity"
        objContacts.BusinessAddressCountry = "BusCountry"
        objContacts.BusinessAddressPostalCode = "Zip Code"
        objContacts.BusinessAddressState = "CA"
        objContacts.BusinessAddressStreet = "BusStreet"
        objContacts.BusinessTelephoneNumber = "BusTelNumber"
        objContacts.HomeAddressCity = "HomeCity"
        objContacts.HomeAddressCountry = "HomeCountry"
        objContacts.HomeAddressPostalCode = "Zip Code 2"
        objContacts.HomeAddressState = "AC"
        objContacts.HomeAddressStreet = "HomeStreet"
        objContacts.HomeTelephoneNumber = "HomeTelNumber"
        objContacts.Save
   
    Set objContacts = Nothing
    Set objNamespace = Nothing
    Set objApp = Nothing
End Sub
correlateAsked:
Who is Participating?
 
rockiroadsConnect With a Mentor Commented:
Hi mate, sorry I didnt get round to this earlier.

When u do the find, it returns you the contact object. So objContacts is populated. We have to create objContacts if it doesnt exist

We can then use a flag to identify if its a new or update operation, this is handy where you want certain fields set on a add only


Private Sub Command256_Click()
   
    Dim objApp As Object
    Dim objNamespace As Object
    Dim oF As Object
    Dim objContacts As Object
    Const olFolderContacts = 10
    Const olContactItem = 2
    Dim bNewItem As Boolean
   
    Set objApp = CreateObject("Outlook.Application")
    Set objNamespace = objApp.GetNamespace("MAPI")
    Set oF = objNamespace.GetDefaultFolder(olFolderContacts)
   
    'RETURN THE ContactsObject
    Set objContacts = oF.items.Find("[Profession] = 'OverpaidDirector'")
       
    'Assume record found
    bNewItem = False
   
    'Create new ContactsObject if not found by above
    If TypeName(objContacts) = "Nothing" Then
        Set objContacts = objApp.CreateItem(olContactItem)
        'Flag to indicate new item
        bNewItem = True
    End If
   
    'SET FIELDS
   
    'TO ENSURE YOU SET FIELDS ON ADD ONLY, USE FLAG
    If bNewItem = True Then
        'Following get set on Add only
        objContacts.Profession = "OverpaidDirector"
    End If
   
    'Following get set on add and update
    objContacts.FirstName = "BBB"
    objContacts.LastName = "AAAA"
    objContacts.Email1Address = "Email@Addr.com"
    objContacts.Title = "Mr"
    objContacts.CompanyName = "Company"
    objContacts.BusinessTelephoneNumber = "OfficePhone"
    objContacts.MobileTelephoneNumber = "MobilePhone"
    objContacts.BusinessAddressCity = "BusCity"
    objContacts.BusinessAddressCountry = "BusCountry"
    objContacts.BusinessAddressPostalCode = "Zip Code"
    objContacts.BusinessAddressState = "CA"
    objContacts.BusinessAddressStreet = "BusStreet"
    objContacts.BusinessTelephoneNumber = "BusTelNumber"
    objContacts.HomeAddressCity = "HomeCity"
    objContacts.HomeAddressCountry = "HomeCountry"
    objContacts.HomeAddressPostalCode = "Zip Code 2"
    objContacts.HomeAddressState = "AC"
    objContacts.HomeAddressStreet = "HomeStreet"
    objContacts.HomeTelephoneNumber = "HomeTelNumber"
   
    'SAVE Contact
    objContacts.Save
   
    Set objContacts = Nothing
    Set objNamespace = Nothing
    Set objApp = Nothing
End Sub

0
 
Shanmuga SundaramDirector of Software EngineeringCommented:
0
 
correlateAuthor Commented:
Thanks for that, it looks like its using a very different method to mine & I was keen to build on this piece of code as I'm a bit more familiar with it & didn't really understand the workings of what they were trying to do in the links (i'm not strong technically)
0
 
correlateAuthor Commented:
Absolute Star - It works perfectly thank you very much
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.