如何在Outlook中回复邮件时自动添加联系人？

Author: Kelly Last Modified: 2025-07-31

在回复邮件时，您可能希望将发件人或收件人自动添加到您的Outlook联系人中。这可以节省时间，并确保您不会丢失重要的联系信息。虽然Outlook本身不支持在回复时自动添加联系人，我将向您介绍两种方法，包括使用Kutools for Outlook的功能，来实现从邮件中自动添加联系人。

使用VBA代码在Outlook中回复邮件时自动添加联系人

使用Kutools批量将多个发件人和收件人从选中的邮件添加到联系人

使用VBA代码在Outlook中回复邮件时自动添加联系人

此VBA代码将在您回复Outlook中的邮件时，自动将发件人和所有收件人作为新联系人添加。请按照以下步骤操作：

1. 按 Alt + F11 键打开Microsoft Visual Basic for Applications窗口。

2. 展开Project1，双击ThisOutlookSession将其打开，然后将以下VBA代码粘贴到ThisOutlookSession窗口中。参见截图：

the screenshot of auto adding contacts from an outlook email when replying with vba

VBA：在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. 保存VBA代码，并重新启动您的Microsoft Outlook。

从现在开始，当您在Outlook中回复邮件时，该邮件的发件人和所有收件人将被自动保存为默认邮箱账户的默认联系人文件夹中的新联系人。