如何在Outlook回覆郵件時自動新增聯絡人？

Author: Kelly Last Modified: 2025-08-06

在回覆郵件時，您可能希望自動將寄件者或收件人新增到您的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中的郵件時，該郵件的寄件者和所有收件人將自動保存為新聯絡人，存入預設郵件帳戶的預設聯絡人資料夾中。