'Thanks to Ken Slovak at http://www.slovaktech.com for this code sample ' The AddAddressesToContacts procedure can go in any Module ' Select the mail folder and any items to add to contacts, then run the macro Public Sub AddAddressesToContacts() Dim folContacts As Outlook.MAPIFolder Dim colItems As Outlook.Items Dim oContact As Outlook.ContactItem Dim oMail As Outlook.MailItem Dim obj As Object Dim oNS As Outlook.NameSpace Dim response As VbMsgBoxResult Dim bContinue As Boolean Dim sSenderName As String On Error Resume Next Set oNS = Application.GetNamespace("MAPI") Set folContacts = oNS.GetDefaultFolder(olFolderContacts) Set colItems = folContacts.Items For Each obj In Application.ActiveExplorer.Selection If obj.Class = olMail Then Set oContact = Nothing bContinue = True sSenderName = "" Set oMail = obj sSenderName = oMail.SentOnBehalfOfName If sSenderName = "" Then sSenderName = oMail.SenderName End If Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'") If Not (oContact Is Nothing) Then response = MsgBox("This appears to be an existing contact: " & sSenderName & ". Do you still want to add it as a new conact?", vbQuestion + vbYesNo, "Contact Adder") If response = vbNo Then bContinue = False End If End If If bContinue Then Set oContact = colItems.Add(olContactItem) With oContact .Body = oMail.Subject .Email1Address = oMail.SenderEmailAddress .Email1DisplayName = sSenderName .Email1AddressType = oMail.SenderEmailType .FullName = oMail.SenderName .Save End With End If End If Next Set folContacts = Nothing Set colItems = Nothing Set oContact = Nothing Set oMail = Nothing Set obj = Nothing Set oNS = Nothing End Sub