Question

有谁知道是否有可能在Outlook 2016中触发签名更改事件？即根据以下屏幕截图模拟单击签名：

我正在尝试根据选择的“发件人”地址自动更改签名。我可以捕获“发件人”地址更改（已解答here）。

但是我找不到以编程方式更改签名的方法。我的研究得出结论，在Office 2016中不推荐CommandBar对象，我需要与IRibbonUI对象进行交互。或者也许是其他一些Ribbon对象？或者除了伪造按钮点击之外，还有更好的方法来选择签名？

我在Signature命名空间中找不到Outlook对象，导致我得出结论MailItem类不知道签名 - 它只知道正文。然而奇怪的是，我可以右键单击签名主体并调出上下文菜单：

所以某些对象必须知道签名 - 也许是电子邮件编辑器？

非常感谢

Answer 1

哇OK好了这么想，但这是实现结果的迂回方式。感谢@niton为this handy comment指出了正确的方向。

总之，它执行以下操作：

当SentOnBehalfOfName中的MailItem属性发生变更时提升事件
根据名为_MailAutoSig
根据选择的发件人选择html签名
插入html签名文件内容并添加名为_MailAutoSig

这是我到目前为止实施的代码：

Dim WithEvents myInspector As Outlook.Inspectors
Dim WithEvents myMailItem As Outlook.MailItem

Private Sub Application_Startup()

    Set myInspector = Application.Inspectors

End Sub

Private Sub myInspector_NewInspector(ByVal Inspector As Outlook.Inspector)

    If TypeOf Inspector.CurrentItem Is MailItem Then
        Set myMailItem = Inspector.CurrentItem
    End If

End Sub

Private Sub myMailItem_PropertyChange(ByVal Name As String)
On Error GoTo ErrorCatcher

    Dim signatureName As String
    Dim signatureFilePath As String

    ' Properties we are interested in: "SendUsingAccount" / "SentOnBehalfOfName"
    ' Both get fired when the 'From' field is changed/re-selected
    ' So we are only going to trigger on one event or we will call the code twice
    If Name = "SentOnBehalfOfName" Then

        ' Delete the current signature
        Call DeleteSignature(myMailItem)

        ' Insert the new signature at the current cursor point
        ' The cursor will be at the point where the old signature was deleted
        signatureName = GetSignatureName(myMailItem.SentOnBehalfOfName)
        signatureFilePath = GetSignatureFilePath(signatureName)
        Call InsertSignature(myMailItem, signatureFilePath)

    End If

    Exit Sub

ErrorCatcher:

    MsgBox Err.Description

End Sub

Private Function DeleteSignature(objMail As MailItem)

    Dim objDoc As Word.Document
    Dim objBkm As Word.Bookmark

    Set objDoc = objMail.GetInspector.WordEditor

    If objDoc.Bookmarks.Exists("_MailAutoSig") Then
        Set objBkm = objDoc.Bookmarks("_MailAutoSig")
        objBkm.Select
        objDoc.Windows(1).Selection.Delete
    End If

End Function

Private Function GetSignatureName(sender As String)

    Select Case sender

        Case "Sender Name 1"
            GetSignatureName = "Signature 1"

        Case "Sender Name 2"
            GetSignatureName = "Signature 2"

        Case Else
            GetSignatureName = "Default"

    End Select


End Function

Private Function GetSignatureFilePath(signatureName As String) As String

    GetSignatureFilePath = Environ("AppData") & "\Microsoft\Signatures\" & signatureName & ".htm"

End Function

Private Function InsertSignature(objMail As MailItem, signatureFilePath As String)

    Dim objDoc As Word.Document
    Dim rngStart As Range
    Dim rngEnd As Range

    Set objDoc = objMail.GetInspector.WordEditor

    Set rngStart = objDoc.Application.Selection.Range
    rngStart.Collapse wdCollapseStart

    Set rngEnd = rngStart.Duplicate
    rngEnd.InsertParagraph

    rngStart.InsertFile signatureFilePath, , , , False
    rngEnd.Characters.Last.Delete

    objDoc.Bookmarks.Add "_MailAutoSig", rngEnd

End Function

触发Outlook事件：更改签名

1 个答案: