Outlook回复邮件自动添加指定联系人组的VBA问题求助

• 场景：经理发邮件安排工作，回复/全部回复时经常漏加特定收件人；仅当原邮件的Body或Subject包含“Test”“VIP”时，才需要添加名为“5-Task Team”的联系人组到收件人。
• 需求：
  1. 点击回复/全部回复后检查邮件内容
  2. 匹配特定词汇时弹出提示
  3. 自动添加指定联系人组到收件人，手动发送邮件
• 当前问题：现有代码仅能弹出提示，无法添加收件人（硬编码邮箱也无效）

现有代码的核心问题是操作了原邮件而非回复窗口的新邮件：

1. Check_Body_before_sendReply里获取的是选中的原邮件（ActiveExplorer().Selection(1)），不是回复生成的待发邮件
2. 没有正确处理联系人组的添加逻辑，硬编码邮箱也因为操作对象错误而无效

1. ThisOutlookSession 代码 #

Option Explicit
Option Compare Text

Private WithEvents myAttExp As Explorer
Private WithEvents myAttOriginatorMail As MailItem

Private Sub Application_Startup()
    Set myAttExp = ActiveExplorer
End Sub

' 处理回复事件
Private Sub myAttOriginatorMail_Reply(ByVal Response As Object, Cancel As Boolean)
    ProcessReplyMail Response
End Sub

' 处理全部回复事件
Private Sub myAttOriginatorMail_ReplyAll(ByVal Response As Object, Cancel As Boolean)
    ProcessReplyMail Response
End Sub

' 选中邮件时绑定事件
Private Sub myAttExp_SelectionChange()
    On Error Resume Next
    If TypeOf myAttExp.Selection.Item(1) Is MailItem Then
        Set myAttOriginatorMail = myAttExp.Selection.Item(1)
    End If
End Sub

2. 独立模块代码 #

Option Explicit
Option Compare Text

Sub ProcessReplyMail(Response As Object)
    Dim olReplyMail As MailItem
    Dim olNS As NameSpace
    Dim distList As DistListItem
    Dim targetGroupName As String
    Dim needAddGroup As Boolean
    
    targetGroupName = "5-Task Team"
    Set olReplyMail = Response
    Set olNS = Application.GetNamespace("MAPI")
    
    ' 检查原邮件的Body和Subject是否含指定关键词
    needAddGroup = (olReplyMail.Parent.Body Like "*Test*" Or olReplyMail.Parent.Body Like "*VIP*") _
                Or (olReplyMail.Parent.Subject Like "*Test*" Or olReplyMail.Parent.Subject Like "*VIP*")
    
    If needAddGroup Then
        MsgBox "检测到关键词，将自动添加「5-Task Team」联系人组到收件人"
        ' 查找并添加联系人组
        On Error Resume Next
        Set distList = olNS.AddressLists("联系人").AddressEntries(targetGroupName).GetExchangeDistributionList
        If Err.Number = 0 Then
            olReplyMail.Recipients.Add targetGroupName
            olReplyMail.Recipients.ResolveAll ' 解析收件人确保有效
        Else
            MsgBox "未找到名为「" & targetGroupName & "」的联系人组，请检查名称是否正确"
        End If
        On Error GoTo 0
    End If
End Sub

• 直接操作回复生成的Response对象（即回复窗口的邮件），不再错误操作原邮件
• 通过olReplyMail.Parent获取原邮件，检查其Body和Subject的关键词
• 使用Outlook地址簿查找联系人组，添加后调用ResolveAll确保收件人解析成功
• 加入错误处理，避免找不到联系人组时程序崩溃

内容的提问来源于stack exchange，提问作者Peace