Class: OutlookContacts in Category Microsoft Outlook : Automation from Total Visual SourceBook

' Example of the COutlookContacts class
'
' To use this example:
' 1.  Create a new form.
' 2.  Create the following command buttons:
'         cmdAddContact
'         cmdAddDistList
'         cmdGetContacts
'         cmdGetContactsFiltered
'         cmdDisplayContact
'         cmdEditContact
'         cmdRenameCompany
'         cmdDeleteContact
' 3.  Create the following text fields:
'         txtTitle
'         txtFirstName
'         txtLastName
'         txtStreet
'         txtCity
'         txtState
'         txtZip
'         txtCountry
'         txtHomePhone
'         txtBusine ssPhone
'         txtFileAs
'         txtEmail
'         txtJobTitle
'         txtCompany
'         txtAddressType
' 4. Run the form

Private Sub cmdAddContact_Click()
  ' Add a contact

  Dim olkContact As COutlookContacts

  If MsgBox("Do you really want to add this contact: " & vbCrLf & Me.txtFirstName & " " & Me.txtLastName & vbCrLf & Me.txtCompany, vbYesNo) = vbYes Then

    Set olkContact = New COutlookContacts

    With olkContact
      .StartOutlook

      .Title = Nz(txtTitle, "")
      .JobTitle = Nz(txtJobTitle, "")
      .Company = Nz(txtCompany, "")
      .HomePhone = Nz(txtHomePhone, "")
      .BusinessPhone = Nz(txtBusinessPhone, "")
      .EMail = Nz(txtEmail, "")
      .FileAs = Nz(txtFileAs, "")
      .FirstName = Nz(txtFirstName, "")
      .LastName = Nz(txtLastName, "")
      .BusinessAddressStreet = Nz(txtStreet, "")
      .BusinessAddressCity = Nz(txtCity, "")
      .BusinessAddressPostalCode = Nz(txtZip, "")
      .BusinessAddressState = Nz(txtState, "")
      .BusinessAddressCountry = Nz(txtCountry, "")

      ' Add the contact
      .AddContact True

    End With

    ' Clean up
    Set olkContact = Nothing
  End If

End Sub

Private Sub cmdAddDistList_Click()
  ' Add a distribution list to Contacts

  Dim olkContact As COutlookContacts

  Dim strDistListName As String
  Dim strMembers As String

  strDistListName = InputBox("Enter the name of the new distribution list:", "Add Distribution List", "TVSB Test List")
  strMembers = InputBox("Enter the email addresses to add to the list (separated by commas):", "Add Distribution List", "fms@fmsinc.com, support@fmsinc.com")

  Set olkContact = New COutlookContacts
  olkContact.StartOutlook
  olkContact.AddDistList strDistListName, strMembers, ",", True

End Sub

Private Sub cmdDeleteContact_Click()
  ' Delete contacts that meet your criteria

  Dim strEmail As String
  Dim olkContact As COutlookContacts
  Dim lngCount As Long

  strEmail = InputBox("Enter the email address for the contacts to delete:")

  If strEmail <> "" Then
    Set olkContact = New COutlookContacts

    olkContact.StartOutlook

    lngCount = olkContact.DeleteContactsByNameCompanyEmail(strEmail:=strEmail)

    If lngCount = 0 Then
      MsgBox "No contacts were deleted for " & strEmail
    Else
      MsgBox lngCount & " contacts were deleted for " & strEmail
    End If

    ' Clean up
    Set olkContact = Nothing
  End If

End Sub

Private Sub cmdDisplayContact_Click()
  ' Get and display the first contact of a company filter

  Dim strCompanyFilter As String
  Dim olkContact As COutlookContacts
  Dim outContact As Outlook.ContactItem

  strCompanyFilter = InputBox("Enter the Company name to get its first contact: ")

  If strCompanyFilter <> "" Then
    Set olkContact = New COutlookContacts
    olkContact.StartOutlook

    Set outContact = olkContact.GetContactItem(True, , , , strCompanyFilter)

    If outContact Is Nothing Then
      MsgBox "No contacts found for " & strCompanyFilter
    Else
      With outContact
        Debug.Print "This contact was found " & .FullName & " at " & .CompanyName & " with email " & .Email1Address & " and business phone " & .BusinessTelephoneNumber
      End With
    End If

    ' Clean up
    Set outContact = Nothing
    Set olkContact = Nothing
  End If

End Sub

Private Sub cmdEditContact_Click()
  ' By getting a specific contact item, you can update its properties.
  ' This example retrieves a contact based on its email address, then gives you the option to update it.

  Dim strCompanyFilter As String
  Dim olkContact As COutlookContacts
  Dim outContact As Outlook.ContactItem
  Dim strMsg As String
  Dim strEmail As String

  strEmail = InputBox("Enter the email address of your contact: ")

  If strEmail <> "" Then
    Set olkContact = New COutlookContacts
    olkContact.StartOutlook

    ' Find the contact, but do not display it if it's found
    Set outContact = olkContact.GetContactItem(False, , , , strEmail)

    If outContact Is Nothing Then
      MsgBox "No contacts found for " & strCompanyFilter
    Else
      With outContact
        strMsg = "This contact was found " & .FullName & " at " & .CompanyName & " with email " & .Email1Address
        strMsg = strMsg & vbCrLf & vbCrLf & "Would you like to update the email address?"
        If MsgBox(strMsg, vbYesNo) = vbYes Then
          strEmail = InputBox("Enter the new email address:", , .Email1Address)
          If strEmail <> "" Then
            .Email1Address = strEmail
            .Save
            MsgBox "Contact updated"
          End If
        End If
      End With
    End If

    ' Clean up
    Set outContact = Nothing
    Set olkContact = Nothing
  End If

End Sub

Private Sub cmdGetContacts_Click()
  ' Display all contacts

  Dim olkContact As COutlookContacts
  Dim colContacts As Collection
  Dim lngCount As Long

  Set olkContact = New COutlookContacts

  olkContact.StartOutlook

  Set colContacts = olkContact.GetContactsAll

  For lngCount = 1 To colContacts.Count
    With colContacts(lngCount)
      Debug.Print lngCount, .FirstName, .LastName, .CompanyName
    End With
  Next lngCount

  If colContacts.Count > 0 Then
    MsgBox colContacts.Count & " contacts found. They are listed in Immediate Window."
  Else
    MsgBox "No contacts found"
  End If

  ' Clean up
  Set olkContact = Nothing
  Set colContacts = Nothing

End Sub

Private Sub cmdGetContactsFiltered_Click()
  ' Filter the list of contacts by company and display them

  Dim strCompanyFilter As String
  Dim olkContact As COutlookContacts
  Dim colContacts As Collection
  Dim lngCount As Long

  ' Get the company name to filter on
  strCompanyFilter = InputBox("Enter the Company name to get contacts for: ")
  If strCompanyFilter <> "" Then
    Set olkContact = New COutlookContacts

    olkContact.StartOutlook

    Set colContacts = olkContact.GetContactsByNameCompanyEmail(True, strCompany:=strCompanyFilter)

    ' Example of filtering on one property
    Set colContacts = olkContact.GetContactsByFilter(True, "CompanyName", strCompanyFilter)

    If colContacts.Count = 0 Then
      MsgBox "No contacts match for " & strCompanyFilter
    Else
      MsgBox colContacts.Count & " contacts found. Also listed in the Immediate Window."
      For lngCount = 1 To colContacts.Count
        With colContacts(lngCount)
          Debug.Print .FirstName, .LastName, .CompanyName, .Email1Address
        End With
      Next lngCount
    End If

    ' Clean up
    Set olkContact = Nothing
    Set colContacts = Nothing
  End If

End Sub

Private Sub cmdRenameCompany_Click()
  ' Rename the company name for all contacts from one to another
  ' This is an easy way to make company names consistent across your contacts.
  ' For instance, you may want to change all "Microsoft" contacts to "Microsoft Corporation" or vice versa

  Dim strCompany As String
  Dim strNewCompany As String
  Dim olkContact As COutlookContacts
  Dim lngCount As Long

  ' Use "Get Filtered Contacts" to return a list of contacts with the specified company name
  strCompany = InputBox("Enter the Company name to get contacts for:")
  If strCompany <> "" Then
    strNewCompany = InputBox("Enter the New Company name:")
    If strNewCompany <> "" Then
      Set olkContact = New COutlookContacts

      olkContact.StartOutlook

      lngCount = olkContact.ReplaceCompanyName(strCompany, strNewCompany)

      If lngCount = 0 Then
        MsgBox "No contacts were updated for " & strCompany
      Else
        MsgBox lngCount & " contacts were updated"
      End If

      ' Clean up
      Set olkContact = Nothing
    End If
  End If

End Sub

Private Sub Form_Load()
  ' Setup controls

  Me.cmdAddContact.Caption = "Add contact"
  Me.cmdAddDistList.Caption = "Add Dist List"
  Me.cmdGetContacts.Caption = "List all contacts"
  Me.cmdGetContactsFiltered.Caption = "List Filtered Contacts"
  Me.txtAddressType = "BUSINESS"
  Me.txtAddressType.Enabled = "False"
  Me.txtBusinessPhone = "703-356-4700"
  Me.txtCompany = "FMS, Inc."
  Me.txtCountry = "United States"
  Me.txtEmail = "fms@fmsinc.com"
  Me.txtFileAs = "FMS, Inc."
  Me.txtFirstName = "FMS"
  Me.txtHomePhone = "703-356-4700"
  Me.txtJobTitle = "World Class Software Solutions"
  Me.txtLastName = "Inc."
  Me.txtStreet = "8150 Leesburg Pike"
  Me.txtTitle = ""
  Me.txtCity = "Vienna"
  Me.txtState = "VA"
  Me.txtZip = "22182"

End Sub

The source code in Total Visual Sourcebook includes modules and classes for Microsoft Access, Visual Basic 6 (VB6), and Visual Basic for Applications (VBA) developers. Easily add this professionally written, tested, and documented royalty-free code into your applications to simplify your application development efforts.

Total Visual SourceBook is written for the needs of a developer using a source code library covering the many challenges you face. Countless developers over the years have told us they learned some or much of their development skills and tricks from our code. You can too!

Additional Resources

• List of All Modules in Total Visual SourceBook
• List of All Code Categories in Total Visual SourceBook
• Sample Module Code from Total Visual SourceBook (Example of Date, Time and Age Calculations)