How to auto add contacts from an email when replying in Outlook?
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.
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.
- Auto CC/BCC by rules when sending email; Auto Forward Multiple Emails by custom; Auto Reply without exchange server, and more automatic features...
- BCC Warning - show message when you try to reply all if your mail address is in the BCC list; Remind When Missing Attachments, and more remind features...
- Reply (All) With All Attachments in the mail conversation; Reply Many Emails in seconds; Auto Add Greeting when reply; Add Date into subject...
- Attachment Tools: Manage All Attachments in All Mails, Auto Detach, Compress All, Rename All, Save All... Quick Report, Count Selected Mails...
- Powerful Junk Emails by custom; Remove Duplicate Mails and Contacts... Enable you to do smarter, faster and better in Outlook.