當您在Outlook中回復電子郵件時，此VBA會自動將電子郵件的發件人和所有收件人添加為新聯繫人。 請執行以下操作：

1。 按 其他 + F11 鍵以打開“ Microsoft Visual Basic應用程序”窗口。

2。 展開Project1，然後雙擊 本次展望會議 打開它，然後將下面的VBA代碼粘貼到ThisOutlookSession窗口中。 看截圖：

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中回復電子郵件時，該電子郵件的發件人和所有收件人將自動作為新聯繫人保存到默認電子郵件帳戶的默認聯繫人文件夾中。

如何在Outlook中從“已發送郵件”電子郵件/文件夾中批量添加聯繫人？

如何在Outlook中將聯繫人批量添加到聯繫人組？