'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
 