To automatically add recipients to Contacts in Outlook using VBA

One thing that Outlook 2002 cannot do by itself is automatically create new entries in Contacts for people you send messages to. This is a feature missed by Outlook 2000 Internet Mail Only users, who had an "Automatically put people I reply to in <folder>" option.

This VBA code sample by Sue Mosher provides a way to add recipients automatically. To avoid the Outlook security prompts, it uses the Redemption library, which provides a wrapper for Extended MAPI that does not trigger the Outlook security prompts. You can download the free version of Redemption for personal use. Use Tools | References in VBA to add a reference to the SafeOutlookLibrary for your project.

The Application_ItemSend procedure must be in the built-in ThisOutlookSession module, but the other two procedures can be in any Outlook VBA module. (Press Alt+F11 to open the VBA window.)

Code Sample #1 (Outlook 2003) | Code Sample #2 (Redemption) | More Information

Code Sample #1 (Outlook 2003)

' sample Outlook 2003 VBA application by Sue Mosher ' send questions/comments to webmaster@outlookcode.com ' The Application_ItemSend procedure must go in the ' built-in ThisOutlookSession session module in Outlook VBA Private Sub Application_ItemSend(ByVal Item As Object, _ Cancel As Boolean) If Item.Class = olMail Then Call AddRecipToContacts(Item) End If Set Item = Nothing End Sub ' This procedure can go in any module Sub AddRecipToContacts(objMail As Outlook.MailItem) Dim strFind As String Dim strAddress As String Dim objNS As Outlook.NameSpace Dim colContacts As Outlook.Items Dim objContact As Outlook.ContactItem Dim objRecip As Outlook.Recipient Dim i As Integer On Error Resume Next ' get Contacts folder and its Items collection Set objNS = Application.GetNamespace("MAPI") Set colContacts = _ objNS.GetDefaultFolder(olFolderContacts).Items ' process message recipients For Each objRecip In objMail.Recipients ' check to see if the recip is already in Contacts strAddress = AddQuote(objRecip.Address) For i = 1 To 3 strFind = "[Email" & i & "Address] = " & _ strAddress Set objContact = colContacts.Find(strFind) If Not objContact Is Nothing Then Exit For End If Next ' if not, add it If objContact Is Nothing Then Set objContact = _ Application.CreateItem(olContactItem) With objContact .FullName = objRecip.Name .Email1Address = strAddress .Save End With End If Set objContact = Nothing Next Set objNS = Nothing Set objContact = Nothing Set colContacts = Nothing End Sub ' helper function - put in any module Function AddQuote(MyText) As String AddQuote = Chr(34) & MyText & Chr(34) End Function

Code Sample #2 (Redemption)

In versions after Outlook 2000 SP2 and before Outlook 2003, you would need to use the Redemption library to avoid security prompts.

' sample application by Sue Mosher ' send questions/comments to webmaster@outlookcode.com ' The Application_ItemSend procedure must go in the ' built-in ThisOutlookSession session module in Outlook VBA Private Sub Application_ItemSend(ByVal Item As Object, _ Cancel As Boolean) If Item.Class = olMail Then Call AddRecipToContacts(Item) End If End Sub ' This procedure can go in any module Sub AddRecipToContacts(objMail As MailItem) Dim strFind As String Dim strAddress As String Dim objSMail As Redemption.SafeMailItem Dim objSRecip As Redemption.SafeRecipient Dim objNS As NameSpace Dim colContacts As Items Dim objContact As ContactItem Dim i As Integer ' process message recipients Set objSMail = CreateObject("Redemption.SafeMailItem") objMail.Save objSMail.Item = objMail Set objNS = Application.GetNamespace("MAPI") Set colContacts = objNS.GetDefaultFolder(olFolderContacts).Items For Each objSRecip In objSMail.Recipients ' check to see if the recip is already in Contacts strAddress = objSRecip.Address For i = 1 To 3 strFind = "[Email" & i & "Address] = " & _ AddQuote(strAddress) Set objContact = colContacts.Find(strFind) If Not objContact Is Nothing Then Exit For End If Next ' if not, add it If objContact Is Nothing Then Set objContact = Application.CreateItem(olContactItem) With objContact .FullName = objSRecip.Name .Email1Address = strAddress .Save End With End If Set objContact = Nothing Next Set objSMail = Nothing Set objSRecip = Nothing Set objNS = Nothing Set colContacts = Nothing End Sub ' helper function - put in any module Function AddQuote(MyText) As String AddQuote = Chr(34) & MyText & Chr(34) End Function

More Information

To add addresses to Microsoft Outlook Contacts automatically -- methods for earlier versions
VB and VBA in Microsoft Outlook -- basics for VBA novices


	© 2002-7 TurtleFlock, LLC All right reserved. About OutlookCode.com Send comments to webmaster@outlookcode.com Designed and Implemented by TerraLink USA FrontPage Integration by RobsonDesignWorks


get Sue's code \| forums \| share your own code \| registration