How to Create Macro in Visual Basic to add Contacts from Personal Folder

Not open for further replies.


Outlook version
Email Account
:confused:Help! My contact list on a prior system was deleted. I have imported all of my emails into my new Microsoft Outlook 2003 but going through all the emails individually to add contacts is horrible when you have thousands of emails. Does anyone have the micro basic code to set up a macro to add contacts from the personal favorite folder?

i.e. click on a message, right address, click on add to contact list, then click on save and close (when outlook creates contact)?

I would really appreciate all the help I can get. Visual Basic looks like greek!

Forum Admin

Senior Member
there are addins you could use - at least i think they might work as you need to use something you can run on mail in your folders.

Here is a code sample that adds them when replying - - you'd need to change it to do it on all messages. (I'll check around and see if anyone has sample code that better meets your needs.)

We have a long list of tools here: - but I'm not sure if any can go through folders and create contacts. (the custom action sample would be prefer using run rules now but it need compiled.)

Forum Admin

Senior Member
Here you go - compliments of at

The macro will work in any selected folder on all selected items in that folder.

Any selected mail items will be harvested. Because I wanted to only use the OOM and you didn’t say if this was 2007 or later only, I didn’t use the MAPI properties for SentOnBehalfOf* other than for name. So the email addresses may not be accurate (for example mails sent to mailing lists will show the list address, not the actual sender's address.)

If this were 2007 or later code only I’d use PropertyAccessor to pick up the PR_SENT_REPRESENTING_ADDRTYPE and PR_SENT_REPRESENTING_EMAIL_ADDRESS properties instead of using SenderEmailAddress and SenderEmailAddressType.

A text file of this code is here:


' 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

Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub
Not open for further replies.