Hey folks,
I had to write a procedure (please see code below) to import or update contacts data from a text file into the user’s main Contacts folder. It goes through each contact in the text file and checks to see if that contact already exists in the Contacts folder. If it does, the contact data is simply updated. If it doesn’t, then a new contact is added to the folder as well as that contact’s data.
I haven’t done a lot of Outlook VBA programming in my career, but I was able to hammer this code out by adapting some great samples from Joe Burns and Sue Mosher.
My procedure works pretty well, but there’s something that bothers me. In order to for the logic to test if each contact in the text file already exists, each time it has to loop through all the contacts in the Contacts folder to check. (That block of code is in red below.) If an user has a large number of contacts in his Contacts folder, this can be slow and inefficient.
Is there some method in Outlook VBA to find an existing contact without looping? Similar to the “Find” methods in Access VBA, i.e., FindFirst, FindNext, etc.
Thanks!
Sub ContactsImportUpdate()
‘****************************************************************************
****************************************************
‘ Written by Stephan Ip, 9/18/2009, adapted from:
‘ 1) Outlook VBA code written by Joe Burns to import contacts from CSV file
‘ http://www.josephjburns.com/2008/08/15/imp…file-using-vba/
‘ and
‘ 2) Outlook VBA code in Sue Mosher’s OutlookCode forum showing how to update (existing) contacts
‘ http://www.outlookcode.com/threads.aspx?fo…messageid=19878
‘ Thank you to both Joe Burns and Sue Mosher for supplying their code and other valuable information.
‘
‘ Imports/updates contacts from CSV file “OutlookContacts.csv” into main contacts folder in Outlook.
‘****************************************************************************
****************************************************
On Error GoTo ContactsImportUpdate_Error
Dim olApp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objItems As Outlook.Items
Dim objItem As Object, objAdd As Object
Dim PathName As String
Dim FileName As String
Dim i As Integer
Dim intFreeFile%
Dim strUserID$, strFirstName$, strLastName$, strBusPhone$, strMobilePhone$, strEmail1$, strVenue$
Dim blnContactFound As Boolean
PathName = “C:” ‘ <– Path of CSV file, can be anywhere
FileName = "OutlookContacts.csv" ' <– Name of csv file
' Bail immediately if the PathName and/or FileName don't exist
If Not PathFileExists(PathName & FileName) Then Exit Sub
Set olApp = CreateObject("Outlook.Application")
Set myNameSpace = olApp.GetNamespace("MAPI")
Set objFolder = myNameSpace.GetDefaultFolder(olFolderContacts) ' <– Main (default) contacts folder
' objFolder.ShowAsOutlookAB = True ' ticks box to see folder content items as contacts
intFreeFile% = FreeFile
Open (PathName & FileName) For Input As intFreeFile%
' Initialize counter var
i = 1
' Loop until the end of file is reached
Do Until EOF(intFreeFile%)
' Read data into variables
Input #intFreeFile%, strUserID$, strFirstName$, strLastName$, strBusPhone$, strMobilePhone$, strEmail1$, strVenue$
If i = 1 Then
' First time around — we're looking at the header line here
' TODO: Validate that we have a text file with the correct fields
GoTo NextLine
End If
Set objItems = objFolder.Items
' Re-set flag
blnContactFound = False
' Loop through all the contacts in the contacts folder, and see if we
' have a match with the LastName and FirstName in the current line,
' and if so, update that contact's data
' TODO: Find out if there's some way to find a matching LastName and FirstName
' in Outlook VBA without having to loop through everything, like maybe an
' equivalent for the FindFirst method in Access VBA?
For Each objItem In objItems
' Make sure we have a contact item
If objItem.Class = olContact Then
If objItem.FileAs = strLastName$ & ", " & strFirstName$ Then
' Match found!
' Set flag and update data
blnContactFound = True
objItem.BusinessTelephoneNumber = strBusPhone$
objItem.MobileTelephoneNumber = strMobilePhone$
objItem.Email1Address = strEmail1$
objItem.Save
End If
End If
Next
' If the contact wasn't found above, then add it
If Not blnContactFound Then
Set objAdd = objItems.Add ' Create a new contact
With objAdd ' Add the data to the new contact
.FirstName = strFirstName$
.LastName = strLastName$
.BusinessTelephoneNumber = strBusPhone$
.MobileTelephoneNumber = strMobilePhone$
.Email1Address = strEmail1$
.FileAs = strLastName$ & ", " & strFirstName$
.Save
End With
End If
NextLine:
' Increment counter var
i = i + 1
Loop
ContactsImportUpdate_Exit:
' Cleanup
Close #intFreeFile% ' Close file
Set objItems = Nothing
Set objFolder = Nothing
Set myNameSpace = Nothing
Set olApp = Nothing
Exit Sub
ContactsImportUpdate_Error:
MsgBox "Error importing/updating Outlook contacts data." & vbCrLf & vbCrLf & _
"Error: " & Err.Number & " – " & Err.Description, vbExclamation, "Contacts Import/Update Error"
Resume ContactsImportUpdate_Exit
End Sub
