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保护