One thing that Outlook cannot do by itself is automatically create new entries in Contacts for people you send messages to.
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
' sample Outlook VBA application by Sue Mosher
' 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)
You 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
Hello!
The code creates duplicates....
Not sure why as there is a check as I can see
It definitely should not be creating duplicates. Is there an existing contact or is it creating two new contacts?