Skip to main content

How to auto add contacts from an email when replying in Outlook?

Author: Kelly Last Modified: 2018-04-11

In Outlook 2010 you can enable the Suggested contacts feature and automatically add recipients as new contacts. However, this Suggested contacts feature is not supported in Outlook 2013 and 2016. Here, I will introduce a VBA to automatically add sender and recipients of an email as new contacts when replying in Outlook.

Auto add contacts from an Outlook email when replying with VBA

Office Tab - Enable Tabbed Editing and Browsing in Microsoft Office, Making Work a Breeze
Unlock Kutools for Outlook's free version now and enjoy over 70 features with unlimited access forever
Boost your Outlook 2021 - 2010 or Outlook 365 with these advanced features. Enjoy 70+ powerful features and elevate your email experience!

Auto add contacts from an Outlook email when replying with VBA

This VBA will automatically add the sender and all recipients of an email as new contacts when you replying the email in Outlook. Please do as follows:

1. Press Alt + F11 keys to open the Microsoft Visual Basic for Applications window.

2. Expand the Project1, and double click ThisOutlookSession to open it, and then paste below VBA code into the ThisOutlookSession window. See screenshot:

VBA: Auto Add Contacts from an email when replying in Outlook

Public WithEvents xExplorer As Outlook.Explorer
Public WithEvents xMailItem As Outlook.MailItem
Sub Application_Startup()
Set xExplorer = Outlook.Application.ActiveExplorer
End Sub

Private Sub xExplorer_SelectionChange()
On Error Resume Next
Set xMailItem = xExplorer.Selection.Item(1)
End Sub

Private Sub xMailItem_Reply(ByVal Response As Object, Cancel As Boolean)
Dim xNameSpace As NameSpace
Dim xSenderAddress As String
Dim xContactItems As Outlook.Items
Dim i, k As Long
Dim xFilterAddress As String
Dim xContact As Outlook.ContactItem
Dim xNewContact As Outlook.ContactItem
Dim Arr() As String
Dim ArrName() As String
Dim xArrCount As Integer
On Error Resume Next
ReDim Arr(xMailItem.Recipients.Count + 1)
ReDim ArrName(xMailItem.Recipients.Count + 1)
xSenderAddress = xMailItem.SenderEmailAddress
Arr(0) = xSenderAddress
ArrName(0) = xMailItem.SenderName
For i = LBound(Arr) + 1 To UBound(Arr) - 1
Arr(i) = xMailItem.Recipients.Item(i).Address
ArrName(i) = xMailItem.Recipients.Item(i).Name
Next i
Set xNameSpace = Outlook.Application.GetNamespace("MAPI")
Set xContactItems = xNameSpace.GetDefaultFolder(olFolderContacts).Items
For i = LBound(Arr) To UBound(Arr) - 1
For k = 1 To 3
xFilterAddress = "[Email" & k & "Address] = " & Arr(i)
Set xContact = xContactItems.Find(xFilterAddress)
If Not (xContact Is Nothing) Then
Exit For
End If
Next k
If xContact Is Nothing Then
Set xNewContact = Outlook.Application.CreateItem(olContactItem)
With xNewContact
.FullName = ArrName(i)
.Email1Address = Arr(i)
.Categories = "From Email"
.Save
End With
End If
Next i
End Sub

3. Save the VBA code, and restart your Microsoft Outlook.

From now on, when you reply an email in Outlook, this email’s sender and all recipients will be saved as new contacts automatically into the default contact folder of default email account.


Related Articles


Best Office Productivity Tools

Breaking News: Kutools for Outlook Launches Free Version!

Experience the all-new Kutools for Outlook FREE version with 70+ incredible features, yours to use FOREVER! Click to download now!

🤖 Kutools AI : Instant pro emails with AI magic--one-click to genius replies, perfect tone, multilingual mastery. Transform emailing effortlessly! ...

📧 Email Automation: Auto Reply (Available for POP and IMAP)  /  Schedule Send Emails  /  Auto CC/BCC by Rules When Sending Email  /  Auto Forward (Advanced Rules)   /  Auto Add Greeting   /  Automatically Split Multi-Recipient Emails into Individual Messages ...

📨 Email Management: Recall Emails  /  Block Scam Emails by Subjects and Others  /  Delete Duplicate Emails  /  Advanced Search  /  Consolidate Folders ...

📁 Attachments ProBatch Save  /  Batch Detach  /  Batch Compress  /  Auto Save   /  Auto Detach  /  Auto Compress ...

🌟 Interface Magic: 😊More Pretty and Cool Emojis   /  Remind you when important emails come  /  Minimize Outlook Instead of Closing ...

👍 One-click Wonders: Reply All with Incoming Attachments  /   Anti-Phishing Emails  /  🕘Show Sender's Time Zone ...

👩🏼‍🤝‍👩🏻 Contacts & Calendar: Batch Add Contacts From Selected Emails  /  Split a Contact Group to Individual Groups  /  Remove Birthday Reminders ...

Instantly unlock Kutools for Outlook with a single click—permanently free. Don't wait, download now and boost your efficiency!

kutools for outlook features1 kutools for outlook features2
 

 

 

Comments (1)
No ratings yet. Be the first to rate!
This comment was minimized by the moderator on the site
Hello, thank you for this code.
But it duplicates (in my case at least) the contacts as many times as I write to them. Any idea?
By the way, in outlook options, the box "search for duplicates when saving a new contact" is checked.
There are no comments posted here yet
Leave your comments
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations