Create Outlook Contacts Overwriting Duplicates

[BallunarCrew]

I need to create Outlook contacts, automatically overwriting duplicates. I have code, shown below, that creates the contacts but creates duplicates. I found the second piece of code that is supposed to loop through the contacts folder and return true if the contact is found. If I can get this to work, I'll next work on updating a contact if I can't simply overrite it. There are two problems with this second piece of code. One is I currently have 30 contacts and when it gets to contact 16, it stops with a type mismatch error on the line Next foundContact. At this point foundContact is Nothing. All previous loops through, it was set to the contact's name. I tried adding the counter to force it to exit when it reached the total number of contacts so that it would not try to go past the end of the searchFolder but it is not even getting to the end of the searchFolder. I do not see anything wrong with the contact data that would cause it to fail on a particular contact. The second problem is that this program will be adding/updating 3500 or so contacts on a regular basis and I do not want the code to have to loop through all the contacts for each one being added/updated to see if it exists. Does anyone know of a search function so I can simply search the Outlook Contacts list for a given contact?

Code to crete contacts - works fine except creates duplicates:
Sub ExportAccessContactsToOutlook()

' Set up DAO Objects.
Dim MyDB As DAO.Database
Dim MyData As DAO.Recordset

Set MyDB = CurrentDb()
Set MyData = MyDB.OpenRecordset("PeopleIno", dbOpenDynaset)

Dim cf As Outlook.MAPIFolder
Dim c As Outlook.ContactItem
Dim Prop As Outlook.UserProperty

Set olns = ol.GetNamespace("MAPI")
Set cf = olns.GetDefaultFolder(olFolderContacts)

With MyData
.MoveFirst
' Loop through the Microsoft Access records.
Do While Not .EOF

If Not (FindAccessContacts(!LastName, !FirstName)) Then
' Create a new Contact item.
Set c = ol.CreateItem(olContactItem)

' Specify which Outlook form to use.
' Change "IPM.Contact" to "IPM.Contact.<formname>" if you've
' created a custom Contact form in Outlook.
c.MessageClass = "IPM.Contact"

' Create all built-in Outlook fields.
'If ![CompanyName] <> "" Then c.CompanyName = ![CompanyName]
If ![FirstName] <> "" Then c.FirstName = ![FirstName]
If ![LastName] <> "" Then c.LastName = ![LastName]
If ![Emailname] <> "" Then c.Email1Address = ![Emailname]
If ![HomePhone] <> "" Then c.PrimaryTelephoneNumber = ![HomePhone]
' Save and close the contact.
c.Save
c.Close olSave
End If
.MoveNext
Loop
End With

End Sub


Code that attempts to determine if contact already exists:

Function FindAccessContacts(ByVal findLastName As String, ByVal findFirstName As String)
Dim folderContacts As Outlook.MAPIFolder
Dim x As Integer
Dim ctCount As Integer
Set olns = ol.GetNamespace("MAPI")
Set folderContacts = olns.GetDefaultFolder(olFolderContacts)

'folderContacts = Me!ActiveExplorer().Session.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderContacts)
Dim searchFolder As Outlook.Items
Dim foundContact As Outlook.ContactItem

Set searchFolder = folderContacts.Items
Dim counter As Integer
Count = 0
ctCount = searchFolder.Count
For Each foundContact In searchFolder
x = x + 1
If foundContact.LastName = findLastName And foundContact.FirstName = findFirstName Then
FindAccessContacts = True
counter = counter + 1
Else
FindAccessContacts = False
End If
If x = ctCount Then
Exit Function
End If

Next foundContact
End Function

 

[kjv1611]

I'm just guessing here, b/c have not tried this myself, but it seems to me that one of your variables is Dimmed incorrectly in the last bit of code.

For instance, you use:
Dim cf As Outlook.MAPIFolder

in the top bit...

and
Dim searchFolder As Outlook.Items

in the bottom.

I believe the contacts folder is a folder in Outlook, so I'd imagine it wouldn't be appropriate to refer to it as an item, but rather a folder.

Take a look there, and post back.