Save money, use VBA
December 24, 2009 • JP • 2 Comments • Rate This Article
• Links to this article
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.
' 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).
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
Outlook ·
Rate This Article:
(No Ratings Yet)
Loading ...What now?
Subscribe To The Blog
Email This Article
Follow Me On Twitter
My Facebook Page
Or just keep reading:
I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space if you want to learn more about VBA. Keep Reading »
Previous Post: ShipTrack 4.0 Now Available
Next Post: Create Distribution Lists from Email
Hi JP
Thanks for the interesting and valuable code that you release. In trying to use the above routine to add the message sender from each item in a folder I get an error. The IsExistingContact function fails for me if the 'name' argument does not contain a space character eg a single word sender name.
Thanks
Matt
I'll update the code in the post, thanks!