asked on

Instruction to open a Contact selected in a List Box in Outlook 2010 via VBA

EE has helped us with a Macro that searches the Contacts in Microsoft Outlook 2010. We have a routine that fills a List Box and displays at the end of the search, what has been found.

We are trying to find the instruction that when we set the control that user double-click on the line with the List Box, it would open THAT Contact record.

Please advice on the proper way to go about this.

Helen Feddema

This can be done in several ways, depending on what information is written to an Access table for display in the listbox. If you have the first and last names in the listbox, this procedure will do the job:

Public Sub OpenAContact()
'Created by Helen Feddema 28-Apr-2015
'Last modified by Helen Feddema 28-Apr-2015

On Error GoTo ErrorHandler

   Dim appOutlook As Outlook.Application
   Dim con As Outlook.ContactItem
   Dim lst As Access.ListBox
   Dim nms As Outlook.NameSpace
   Dim fldContacts As Outlook.Folder
   Dim strFilter As String
   Dim strFirstName As String
   Dim strLastName As String
   Dim strFullName As String
   Dim varTest As Variant
   
   Set appOutlook = GetObject(, "Outlook.Application")
   
   'Get data from selected item in listbox -- modify as needed
   'for your form
   Set lst = Forms![frmTest]![lstContacts]
   strFirstName = Nz(lst.Column(0))
   strLastName = Nz(lst.Column(1))
   strFullName = strFirstName & " " & strLastName
   Debug.Print "Full name: " & strFullName
   
SelectContactsFolder:
   Set nms = appOutlook.GetNamespace("MAPI")
   Set fldContacts = nms.PickFolder
   
   If fldContacts Is Nothing Then
      GoTo ErrorHandlerExit
   ElseIf fldContacts.DefaultItemType <> olContactItem Then
      strPrompt = "Please select a Contact folder"
      strTitle = "Select folder"
      MsgBox prompt:=strPrompt, _
         buttons:=vbExclamation + vbOKOnly, _
         Title:=strTitle
      GoTo SelectContactsFolder
   End If
   
'Try finding contact by FullName:
   strFilter = "[FirstName] = " & Chr(39) & strFirstName _
      & Chr(39) & " And [LastName] = " & Chr(39) _
      & strLastName & Chr(39)
   Debug.Print "Filter string: " & strFilter
       
   Set varTest = fldContacts.Items.Find(strFilter)
                  
   If IsNull(varTest) = True Then
      strTitle = "Can't find contact"
      strPrompt = strFullName _
         & " is not in " & fldContacts.Name & "; exiting"
      MsgBox prompt:=strPrompt, _
         buttons:=vbExclamation + vbOKOnly, _
         Title:=strTitle
      GoTo ErrorHandlerExit
   Else
      Set con = fldContacts.Items(strFullName)
   End If
      
DisplayContact:
   con.Display
   
ErrorHandlerExit:
   Set appOutlook = Nothing
   Set con = Nothing
   Exit Sub

ErrorHandler:
   'Outlook is not running; open Outlook with CreateObject
   If Err.Number = 429 Then
      Set appOutlook = CreateObject("Outlook.Application")
      Resume
   Else
   MsgBox "Error No: " & Err.Number _
      & " in OpenAContact procedure; " _
      & "Description: " & Err.Description
      Resume ErrorHandlerExit
   End If

End Sub