Save money, use VBA

I was browsing the Internet recently and found a company that sells Outlook add-ins for various purposes (I won't mention the company). What a shame, because a few lines of VBA code could save dozens or hundreds of dollars that might be otherwise spent on frivolous add-ins that remind you if you forgot an attachment, or automatically BCC someone, or something similar. As long as you're OK with giving up a pretty UI (with the company's logo plastered on it, of course) and are willing to get into the trenches and debug your own code.

This is the first post in a series on how to Save Money In Outlook by writing your own code (or just cutting and pasting what you find here ). But isn't that what this site is all about anyway?

Automatically Add Contacts on Outgoing Messages

Do you want to automatically add recipients as contacts, whenever you send an email?

The following VBA event handler will automatically add outgoing recipient email addresses as contacts in your Contacts folder (if they don't already exist there). It can be customized to add only the people you reply to (Replies), or only the people you send to (New Messages). It can be customized to include CC/BCC recipients as well.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
' automatically add outgoing recipient to default Contacts folder
' assumes one recipient, otherwise it adds the first recipient only
' assumes that recipient is listed in "Firstname Lastname" format
  On Error GoTo ErrorHandler

  Dim Msg As Outlook.MailItem
  Dim contactItm As Outlook.ContactItem

  ' only act on mailitems
  If Not IsMail(Item) Then GoTo ProgramExit

  ' check if recipient is a contact
  Set Msg = Item

  If Not IsExistingContact(Msg.To) Then
    ' add contact
    Set contactItm = GetOutlookApp.CreateItem(olContactItem)

    With contactItm
      .FullName = Msg.To
      .Email1Address = Msg.Recipients.Item(1).Address
      .Close olSave
    End With
  End If

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.number & " - " & Err.Description
  Resume ProgramExit
End Sub

Function IsExistingContact(name As String) As Boolean

Dim itm As Object
Dim Itms As Outlook.Items
Dim firstName As String
Dim lastName As String

  ' search for the name
  Set Itms = GetItems(GetNS(GetOutlookApp), olFolderContacts)

  ' parse the name
  If InStr(name, " ") = 0 Then

  Set itm = Itms.Find("[FullName] =" & Chr(34) & name & Chr(34))

  Else

    firstName = Left$(name, InStr(name, " ") - 1)
    lastName = Right$(name, Len(name) - InStrRev(name, " "))

    Set itm = Itms.Find("[FirstName] =" & Chr(34) & firstName & Chr(34) & _
                      " And [LastName] = " & Chr(34) & lastName & Chr(34))

  End If

  IsExistingContact = (Not itm Is Nothing)

End Function

Function IsMail(itm As Object) As Boolean
  IsMail = (TypeName(itm) = "MailItem")
End Function

Function GetOutlookApp() As Outlook.Application
' returns native Outlook.Application object
  Set GetOutlookApp = Outlook.Application
End Function

Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
' returns native NameSpace Object
  Set GetNS = app.GetNamespace("MAPI")
End Function

Function GetItems(olNS As Outlook.NameSpace, _
                  folder As OlDefaultFolders) As Outlook.Items
' returns Items collection for specified default folder
  Set GetItems = olNS.GetDefaultFolder(folder).Items
End Function

To check if a contact already exists, we use the Find Method on the Items Collection for the default Contacts folder. If the contact does not exist, our object reference will point to Nothing.

Create Contacts from emails in a folder

I think this could be a blog post on its own. In addition to adding contacts automatically from outgoing messages, we can also imagine a scenario where we need to do this for emails in a folder. The following VBA code will loop through all emails in a folder (either the default Inbox, or a folder of your choosing) and check if the recipient (or sender) is already in your Contacts folder. If not, they're added as a contact (name and email address only).

Sub LoopThroughFolderAddContacts()

  On Error GoTo ErrorHandler

  Dim Msg As Outlook.MailItem
  Dim MsgRecips As Outlook.Recipients
  Dim MsgRecip As Outlook.Recipient
  Dim emailItm As Outlook.MailItem
  Dim Itms As Outlook.Items
  Dim contactItm As Outlook.ContactItem

  ' loop through default Inbox
  Set Itms = GetItems(GetNS(GetOutlookApp), olFolderInbox)
  ' or to pick your folder:
  ' Set Itms = GetNS(GetOutlookApp).PickFolder.Items

  ' loop through each email
  For Each emailItm In Itms

    Set Msg = emailItm

    ' loop through each recipient and sender in email
    Set MsgRecips = Msg.Recipients

    For Each MsgRecip In MsgRecips
      If Not IsExistingContact(MsgRecip.name) Then
        ' add contact
        Set contactItm = GetOutlookApp.CreateItem(olContactItem)

        With contactItm
          .FullName = MsgRecip.name
          .Email1Address = MsgRecip.Address
          .Close olSave
        End With
      End If
    Next MsgRecip

    ' add msg sender as well?
    If Not IsExistingContact(Msg.SenderName) Then
      ' add sender as contact
      Set contactItm = GetOutlookApp.CreateItem(olContactItem)

      With contactItm
        .FullName = Msg.SenderName
        .Email1Address = Msg.SenderEmailAddress
        .Close olSave
      End With
    End If

  Next emailItm

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Related Articles:

• January 31, 2011 -- Add photos to Contacts in bulk using VBA in Outlook
• September 6, 2008 -- Export Outlook Contacts to Excel
• February 26, 2008 -- Resending Outlook Messages via VBA Code