• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 641
  • Last Modified:

Macro to Add Contacts based on Names in the To Line

Hi Experts,

Could someone provide the VBA code that adds new contacts based on the names /contacts listed in the "To" line of an email?  

By the way, I have multiple names (over 100) listed on my To line.

I have seen some code on EE already but they seem to add contacts based on the name listed in sender.

Many Thanks,
RR
0
rav_rav
Asked:
rav_rav
  • 3
  • 2
1 Solution
 
David LeeCommented:
Hi, RR.

I can help with this.  Do you want the script to run automatically or manually?
0
 
rav_ravAuthor Commented:
Script to run manually.  Thanks
0
 
David LeeCommented:
Here's the code.  Follow these instructions to add it to Outlook.

1.  Start Outlook
2.  Press ALT+F11 to open the Visual Basic Editor
3.  If not already expanded, expand Microsoft Office Outlook Objects
4.  If not already expanded, expand Modules
5.  Select an existing module (e.g. Module1) by double-clicking on it or create a new module by right-clicking Modules and selecting Insert > Module.
6.  Copy the code from the Code Snippet box and paste it into the right-hand pane of Outlook's VB Editor window
7.  Edit the code as needed.  I included comments wherever something needs to or can change
8.  Click the diskette icon on the toolbar to save the changes
9.  Close the VB Editor

Sub HarvestAddresses()
    Const SCRIPT_NAME = "Harvest Addresses"
    Dim olkItem As Outlook.MailItem
    Select Case TypeName(Application.ActiveWindow)
        Case "Explorer"
            For Each olkItem In Application.ActiveExplorer.Selection
                ProcessMessage olkItem
            Next
        Case "Inspector"
            ProcessMessage Application.ActiveInspector.CurrentItem
    End Select
    MsgBox "Finished", vbInformation + vbOKOnly, SCRIPT_NAME
End Sub

Sub ProcessMessage(olkMail As Outlook.MailItem)
    Dim olkMail As Outlook.MailItem, _
        olkRpnt As Outlook.Recipient, _
        olkCont As Outlook.ContactItem
    For Each olkRpnt In olkMail.Recipients
        Set olkCont = GetContact(olkRpnt.Address)
        If TypeName(olkCont) = "Nothing" Then
            Set olkCont = Application.CreateItem(olContactItem)
            With olkCont
                .Email1Address = olkRpnt.Address
                .FullName = olkRpnt.Name
                .Save
            End With
        End If
    Next
    Set olkMail = Nothing
    Set olkRpnt = Nothing
    Set olkCont = Nothing
End Sub

Function GetContact(strAddress As String) As Outlook.ContactItem
    Dim olkContacts As Outlook.Items, olkContact As Outlook.ContactItem
    Set olkContacts = Session.GetDefaultFolder(olFolderContacts).Items
    Set olkContact = olkContacts.Find("[Email1Address]='" + strAddress + "'" + " OR [Email2Address]='" + strAddress + "'" + " OR [Email3Address]='" + strAddress + "'")
    Set GetContact = olkContact
End Function

Open in new window


To use this solution

1.  Select one or more emails or open an email.
2.  Run the macro.

The macro loops through each email's addressees.  For each one it searches Contacts to see if a contact with that address already exists.  If it does not find one, then it adds a contact.  If one is found, then it does nothing.
0
 
rav_ravAuthor Commented:
Great; thanks for your help.
0
 
David LeeCommented:
You're welcome!
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

  • 3
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now