How to add to Outlook contacts each and every selected name from a draft message ?

[Romulus]

Hi all,

I need your assistance. I have expanded a distribution list of 1700+ names into the actual list of those names. Let assume I have this list in a saved draft e-mail message and the whole list is selected (CTRL + A).

Is there any automated way to add each and every of those 1700+ names to Outlook contacts, other than right clicking and choosing "Add to Outlook Contacts" one name at the time ?

For several names it would not be a problem for me, but the list contains 1700+ names and it will take me a century to do it, not to mention that I could miss someone.

Please advise. Any other similar idea that could solve the problem will be very much appreciated. I have tried to find a thread with this subject, but I have not found anything.

I guess a VBA solution will do the trick, so please be generous with the details (what to do with the code to "install" it and then to run it, etc.). :help

I am using Microsoft Outlook 2010. Thank you in advance.

My best regards,
Romulus.

[skatonni]

Run this on an open item.


Sub AddRecip_test()

' This procedure can go in any module
Dim objMail As mailItem
Set objMail = ActiveInspector.currentItem

AddRecipToContacts objMail

Set objMail = Nothing
End Sub


' The code is here http://www.outlookcode.com/d/code/autoaddrecip.htm
' You do not need Application_ItemSend for your purpose. It is replaced by the code above.


' sample Outlook 2003 VBA application by Sue Mosher

' 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
Debug.Print " - objRecip: " & objRecip
' 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


If you are unfamiliar with VBA see here http://www.slipstick.com/developer/how-to-use-outlooks-vba-editor/


You will find information about:
- macro security settings
- where to put the code (You can use a regular module with Insert | Module)
- how to create a button

[Romulus]

Hello,

Thank your for your assistance. I used the code you proposed, I ran it, I got no errors. I took my chance and added few more things to the code you proposed, basically I wanted contacts to contain more information than contact name and e-mail address.

I marked the lines I added with a comment line right above the added line. Comment line is: 'Line below was added;

I did not use AddQuote function you added at the end of the code, beacause e-mail address field did not return expected result.

I used the code below on a test exercise, for 4 recipients, it returned no errors, as well.

However, 3 lines to not return expected results:

- line 1/3: .Email1DisplayName = objRecip.AddressEntry.GetExchangeUser.FirstName & " " & objRecip.AddressEntry.GetExchangeUser.LastName & "Whyyyy ?"

- line 2/3: .HomeTelephoneNumber = ProprAccessor.GetProperty("urn:schemas:contacts:homePhone")

- line 3/3: .ManagerName = ProprAccessor.GetProperty("urn:schemas:contacts:manager")

First error line (line 1/3 above) does return expected result, it returns Full name followed by e-mail address, instead of full name, only. I do not want e-mail address in this field, I just need full name, nothing else.

For both ProprAccessor lines (lines 2/3 and 3/3 above), I tried something: I commented line On Error Resume Next and it returned "Object variable or With block variable not set" error for below line: .

Set ProprAccessor = objRecip.PropertyAccessor

I guess I did not define properly that Property Accessor.

Another point: code you proposed contains a verification section, whether the contact exists, or not, before creating a new one, with the same name, or so. Accidentally, I ran the code having some previously created contact, some of the new contacts created by the code were duplication of some existing contacts, but the software did not react in any way.

How the code is supposed to react when a duplicated contact is about to be created ? Is the user asked whether to create the duplicated contact, or not ?

Do you have any suggestions, how to resolve all these issues ? Please advise. Thank you.

My best regards,
Romulus.


Option Explicit

Sub AddRecip_test()
' This procedure can go in any module
Dim objMail As MailItem
Set objMail = ActiveInspector.CurrentItem

AddRecipToContacts objMail

Set objMail = Nothing
End Sub




' sample Outlook 2003 VBA application by Sue Mosher

' 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
'Line below was added;
Dim ProprAccessor As Outlook.PropertyAccessor
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
'Line below was added;
Set ProprAccessor = objRecip.PropertyAccessor

' process message recipients
For Each objRecip In objMail.Recipients
Debug.Print " - objRecip: " & objRecip
' check to see if the recip is already in Contacts
'strAddress = AddQuote(objRecip.Address)
strAddress = 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
'Line below was added;
.JobTitle = objRecip.AddressEntry.GetExchangeUser.JobTitle
.Email1Address = strAddress
'Line below was added;
.Email1DisplayName = objRecip.AddressEntry.GetExchangeUser.FirstName & " " & objRecip.AddressEntry.GetExchangeUser.LastName & "Whyyyy ?"
'Line below was added;
.BusinessTelephoneNumber = objRecip.AddressEntry.GetExchangeUser.BusinessTelephoneNumber
'Line below was added;
.HomeTelephoneNumber = ProprAccessor.GetProperty("urn:schemas:contacts:homePhone")
'Line below was added;
.MobileTelephoneNumber = objRecip.AddressEntry.GetExchangeUser.MobileTelephoneNumber
'Line below was added;
.Department = objRecip.AddressEntry.GetExchangeUser.Department
'Line below was added;
.ManagerName = ProprAccessor.GetProperty("urn:schemas:contacts:manager")
'Line below was added;
.Account = objRecip.AddressEntry.GetExchangeUser.Alias
'Line below was added;
.Business2TelephoneNumber = "VoIP: 337 " & Right(objRecip.AddressEntry.GetExchangeUser.BusinessTelephoneNumber, 4)




.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

[skatonni]

I did not use AddQuote function you added at the end of the code, beacause e-mail address field did not return expected result.
This is part of the code that determines whether the contact already exists. If you need it then save the unchanged strAddress somewhere else before adding quotes.




However, 3 lines to not return expected results:

- line 1/3: .Email1DisplayName = objRecip.AddressEntry.GetExchangeUser.FirstName & " " & objRecip.AddressEntry.GetExchangeUser.LastName & "Whyyyy ?"

- line 2/3: .HomeTelephoneNumber = ProprAccessor.GetProperty("urn:schemas:contacts:homePhone")

- line 3/3: .ManagerName = ProprAccessor.GetProperty("urn:schemas:contacts:manager")

First error line (line 1/3 above) does return expected result, it returns Full name followed by e-mail address, instead of full name, only. I do not want e-mail address in this field, I just need full name, nothing else.

For both ProprAccessor lines (lines 2/3 and 3/3 above), I tried something: I commented line On Error Resume Next and it returned "Object variable or With block variable not set" error for below line: .

Set ProprAccessor = objRecip.PropertyAccessor

I guess I did not define properly that Property Accessor.

For line 1/3 - You can debug to see the values. http://www.cpearson.com/excel/DebuggingVBA.aspx

For lines 2/3 and 3/3 - In principle Set ProprAccessor = objRecip.PropertyAccessor should appear after objRecip is known. But it does not matter since you do not have a contact to use it on.

See here for an example. http://www.gregthatcher.com/Scripts/VBA/Outlook/GetListOfContactsUsingPropertyAccessor.aspx

The key line is Set ContactFolder = Session.GetDefaultFolder(olFolderContacts).

It is best not to have "On Error Resume Next" unless it has a specific purpose. Especially problematic when debugging. If it is necessary then an On Error Goto 0 should soon follow.




Another point: code you proposed contains a verification section, whether the contact exists, or not, before creating a new one, with the same name, or so. Accidentally, I ran the code having some previously created contact, some of the new contacts created by the code were duplication of some existing contacts, but the software did not react in any way.

How the code is supposed to react when a duplicated contact is about to be created ? Is the user asked whether to create the duplicated contact, or not ?

If there is a previously created contact, the code moves on to the next name.