Outlook VBA ItemSend事件未触发 按收件人域自动切换签名失效

发送邮件时ItemSend事件设置的断点未触发，说明该事件调用存在异常。相关代码已放置在Application对象窗口的ThisOutlookSession模块中，已激活的引用列表见截图：

企业需要对仅包含内部收件人的邮件、包含至少1名外部收件人的邮件使用不同签名，手动选择签名效率较低，因此尝试通过Outlook宏实现签名自动切换。
预期实现效果：收件人均为母公司、子公司内部域用户时，插入包含内部链接的内部签名；只要收件人包含非内部域的外部用户，就插入移除了内部链接的外部签名。

参考公开的Outlook签名自动配置方案，结合多内部域判断的数组逻辑编写的初始代码如下：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim pa As PropertyAccessor

    Dim prompt As String
    Dim rAddress As String

    Dim lLen As Long
    Dim Str1 As String

    Dim arrayDomains() As Variant
    Dim i As Long

    Dim internalFlag As Boolean
    Dim externalFlag As Boolean

    Dim strExtAdd As String

    Dim xMailItem As MailItem
    Dim xFSO As Scripting.FileSystemObject
    Dim xSignatureFile, xSignaturePath As String
    Dim xDoc As Document


    Set xMailItem = Item

    arrayDomains = Array("internal.com", "subsidiary.com")

    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

    xSignaturePath = "C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures\" 'CreateObject("WScript.Shell").SpecialFolders(5) + "\Microsoft\Signatures\"

    Set recips = Item.Recipients

    For Each recip In recips

        Set pa = recip.PropertyAccessor

        rAddress = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
        lLen = Len(rAddress) - InStrRev(rAddress, "@")
        Str1 = Right(rAddress, lLen)

        internalFlag = False

        For i = LBound(arrayDomains) To UBound(arrayDomains)
            If Str1 = arrayDomains(i) Then
                internalFlag = True
                Exit For
            End If
        Next

        If internalFlag = False Then
            externalFlag = True
        End If

    Next

    If externalFlag = True Then

        xSignatureFile = xSignaturePath & "ext.htm"

    Else

        xSignatureFile = xSignaturePath & "int.htm"

    End If


    VBA.DoEvents
    Set xDoc = xMailItem.GetInspector.WordEditor
    xDoc.Application.Selection.EndKey
    xDoc.Application.Selection.InsertParagraphAfter
    xDoc.Application.Selection.MoveDown Unit:=wdLine, Count:=1
    xDoc.Application.Selection.InsertFile FileName:=xSignatureFile, Link:=False, Attachment:=False
End Sub

代码运行无效果，无法自动向邮件中插入对应签名。

事件不触发问题排查 #

• 调整宏安全配置：进入Outlook选项→信任中心→信任中心设置→宏设置，选择对所有宏提供通知，测试阶段可临时选择启用所有宏，配置完成后重启Outlook再测试事件触发状态
• 确认代码存放位置：事件代码必须放在Outlook VBA编辑器中Application对象对应的ThisOutlookSession模块内，存放在标准模块的事件过程不会被Outlook识别执行

代码逻辑缺陷修复 #

原有代码存在多处会导致执行中断的问题，修复要点如下：

• 补全所有变量声明，显式初始化externalFlag标记位，避免隐式变量带来的逻辑异常
• 增加收件人解析逻辑，读取SMTP地址前先确认收件人已解析，避免地址读取失败
• 增加错误容错，个别收件人无有效SMTP地址时跳过判断，不中断整个流程
• 补全wdLine常量定义，将Word文档对象改为Object类型声明，降低对Word对象库引用的强依赖，避免引用丢失导致的执行失败
• 增加签名文件存在性校验，文件缺失时直接退出过程不报错
• 识别到外部收件人后提前退出遍历循环，提升执行效率
• 增加项目类型判断，仅对邮件类型项目执行签名插入逻辑，避免会议邀约、任务等其他类型项目触发报错

修复后的可直接运行代码如下：

Const wdLine As Long = 5
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim pa As PropertyAccessor
    Dim rAddress As String
    Dim lLen As Long
    Dim Str1 As String
    Dim arrayDomains() As Variant
    Dim i As Long
    Dim internalFlag As Boolean
    Dim externalFlag As Boolean
    Dim xMailItem As MailItem
    Dim xSignatureFile As String, xSignaturePath As String
    Dim xDoc As Object
    Dim recips As Recipients, recip As Recipient

    If TypeName(Item) <> "MailItem" Then Exit Sub
    Set xMailItem = Item

    arrayDomains = Array("internal.com", "subsidiary.com")
    externalFlag = False

    xSignaturePath = Environ("APPDATA") & "\Microsoft\Signatures\"
    Set recips = xMailItem.Recipients

    For Each recip In recips
        If Not recip.Resolved Then recip.Resolve
        Set pa = recip.PropertyAccessor
        On Error Resume Next
        rAddress = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
        On Error GoTo 0
        If rAddress <> "" Then
            lLen = Len(rAddress) - InStrRev(rAddress, "@")
            Str1 = Right(rAddress, lLen)
            internalFlag = False
            For i = LBound(arrayDomains) To UBound(arrayDomains)
                If Str1 = arrayDomains(i) Then
                    internalFlag = True
                    Exit For
                End If
            Next
            If Not internalFlag Then
                externalFlag = True
                Exit For
            End If
        End If
    Next

    If externalFlag Then
        xSignatureFile = xSignaturePath & "ext.htm"
    Else
        xSignatureFile = xSignaturePath & "int.htm"
    End If

    If Dir(xSignatureFile) = "" Then Exit Sub

    VBA.DoEvents
    Set xDoc = xMailItem.GetInspector.WordEditor
    xDoc.Application.Selection.EndKey
    xDoc.Application.Selection.InsertParagraphAfter
    xDoc.Application.Selection.MoveDown Unit:=wdLine, Count:=1
    xDoc.Application.Selection.InsertFile FileName:=xSignatureFile, Link:=False, Attachment:=False
End Sub

注意：使用前需要将代码中arrayDomains数组内的域名替换为企业实际的内部邮件域名，同时确认签名文件夹内存在int.htm（内部签名）和ext.htm（外部签名）两个签名文件。

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