Note: The other languages of the website are Google-translated. Back to English

在Outlook中回复時如何自動從電子郵件中添加聯繫人?

在Outlook 2010中,您可以啟用 建議聯絡人 並自動將收件人添加為新聯繫人。 但是這個 建議聯絡人 Outlook 2013和2016不支持此功能。在這裡,我將介紹一個VBA,以便在Outlook中回复時自動將電子郵件的發件人和收件人作為新聯繫人添加。

使用VBA答复時,自動從Outlook電子郵件中添加聯繫人

Office選項卡-在Office中啟用選項卡式編輯和瀏覽,並使工作更加容易...
Kutools for Outlook-為Microsoft Outlook帶來100種強大的高級功能
  • 自動CC / BCC 根據規則發送電子郵件; 自動前進 按規則發送多封電子郵件; 自動回复 沒有交換服務器,還有更多自動功能...
  • BCC警告 -如果您的郵件地址在密件抄送列表中,則當您嘗試全部答复時顯示消息; 缺少附件時提醒,還有更多提醒功能...
  • 回复(全部)帶有所有附件 在郵件對話中; 一次回复許多電子郵件; 自動添加問候語 回复時自動將日期和時間添加到主題中...
  • 附件工具:自動分離,全部壓縮,重命名,自動保存所有... 快速報告,計算所選郵件, 刪除重複的郵件和聯繫人...
  • 超過 100 項高級功能將 解決您的大部分問題 在 Outlook 2021 - 2010 或 Office 365 中。完整功能 60 天免費試用。

使用VBA答复時,自動從Outlook電子郵件中添加聯繫人

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


相關文章


Kutools for Outlook-為Outlook帶來100個高級功能,並使工作更加輕鬆!

  • 自動CC / BCC 根據規則發送電子郵件; 自動前進 自定義多封電子郵件; 自動回复 沒有交換服務器,還有更多自動功能...
  • BCC警告 -當您嘗試全部答复時顯示消息 如果您的郵件地址在“密件抄送”列表中; 缺少附件時提醒,還有更多提醒功能...
  • 在郵件對話中回复(全部)帶有所有附件; 回复許多電子郵件 片刻之間; 自動添加問候語 回复時將日期添加到主題中...
  • 附件工具:管理所有郵件中的所有附件, 自動分離, 全部壓縮,重命名全部,保存全部...快速報告, 計算選定的郵件...
  • 強大的垃圾郵件 習俗 刪除重複的郵件和聯繫人... 使您能夠在Outlook中做得更聰明,更快和更好。
拍攝kutools前景kutools選項卡1180x121
拍攝kutools前景kutools加標籤1180x121
 
按評論排序
留言 (1)
還沒有評分。 成為第一位評論!
網站主持人對此評論進行了最小化
您好,感謝您提供此代碼。
但它複製(至少在我的情況下)聯繫人的次數與我寫給他們的次數一樣多。 任何想法?
順便說一句,在 Outlook 選項中,選中了“保存新聯繫人時搜索重複項”框。
這裡還沒有評論
留下你的意見
以訪客身份發帖
×
評價此帖子:
0   字符
推薦地點

關注我們

版權所有©2009 - 萬維網。extendoffice.com。 | 版權所有。 供電 ExtendOffice。 |
Microsoft和Office徽標是Microsoft Corporation在美國和/或其他國家的商標或註冊商標。
受Sectigo SSL保護