How To Auto Add Contacts From An Email In Outlook When Replying?

Previous, in Outlook 2010, a user could enable the Suggested contacts feature that would enable the automatic addition of recipients as new contacts.

However, this Suggested contacts feature is not supported in Outlook 2013 and 2016. The only way is to use a third party add on such as mapi labs or use a VBA script.

Here, I will introduce a VBA to automatically add sender and recipients of an email as new contacts when replying in Outlook.

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
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 the default email account.

Share on Facebook Share on Twitter
Post Views: 3,154

Related Posts:

  • safhome plus
    How to pay for Safaricom Home fibre     Safaricom Home Fibre called SAF-HOME is an internet connectivity offering from Safaricom Kenya Limited. Saf-home is one of the largest providers of Internet connectivity for homes in Kenya.

Leave a Reply