Results 1 to 3 of 3
  1. #1
    New Lounger
    Join Date
    Feb 2009
    New York, New York
    Thanked 0 Times in 0 Posts
    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.


    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
    ' and
    ' 2) Outlook VBA code in Sue Mosher's OutlookCode forum showing how to update (existing) contacts
    ' 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$
    End If
    End If

    ' 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$
    End With
    End If

    ' Increment counter var
    i = i + 1

    ' Cleanup
    Close #intFreeFile% ' Close file
    Set objItems = Nothing
    Set objFolder = Nothing
    Set myNameSpace = Nothing
    Set olApp = Nothing
    Exit Sub

    MsgBox "Error importing/updating Outlook contacts data." & vbCrLf & vbCrLf & _
    "Error: " & Err.Number & " - " & Err.Description, vbExclamation, "Contacts Import/Update Error"
    Resume ContactsImportUpdate_Exit

    End Sub
    [pre]Stephan Ip

  2. #2
    Plutonium Lounger
    Join Date
    Mar 2002
    Thanked 28 Times in 28 Posts
    The items collection of a MAPIFolder has a Find method:

    Set objItem = objItems.Find("[FileAs]=" & Chr(34) & strLastName$ & ", " & strFirstName$ & Chr(34))
    If Not TypeName(objItem) = "Nothing" Then
      ' Match found
    End If

  3. #3
    New Lounger
    Join Date
    Feb 2009
    New York, New York
    Thanked 0 Times in 0 Posts
    Thank you Hans!

    Your reputation as a master in these forums is certainly well-deserved.
    [pre]Stephan Ip

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts