vba - 根据收件人主动更改电子邮件签名

问题描述

我正在尝试创建一个宏，该宏将根据 To、CC 和 BCC 行中的地址主动更改/更新用户电子邮件签名。我有 2 种签名样式，“Internal.htm”用于在公司内部发送的电子邮件，“External.htm”用于在公司外部发送的电子邮件，但仅限于发送给外部用户的第一条消息。如果电子邮件链中已经存在“外部”签名，则将使用“内部”签名。因此，在撰写新电子邮件时，默认签名将显示为“外部”，如果您输入公司内部人员的电子邮件地址，则签名将更改为“内部”。

我已经能够从各种站点找到与我正在寻找的代码非常接近的代码位，但是由于我对 VBA 非常陌生，因此我没有成功地将所有内容拼凑在一起。

我在“ThisOutlookSession”中有以下代码：

Public aeh As AppEventsHandler
Public GFSO As Scripting.FileSystemObject
Public WithEvents myItem As Outlook.mailItem

Private Sub Application_Startup()
    Set aeh = New AppEventsHandler
    aeh.Class_Initialize
    Set GExplorer = Outlook.Application.ActiveExplorer
    Set GFSO = New Scripting.FileSystemObject
End Sub

以及名为“AppEventHandler”的类模块中的以下代码：

'[AppEventsHandler] (class module)
Option Explicit
Public WithEvents aehApp As Outlook.Application
Public WithEvents aehExp As Outlook.Explorer
Public WithEvents aehMailItem As Outlook.mailItem

Public Sub Class_Initialize()
    Set aehApp = Outlook.Application
    Set aehExp = Application.ActiveExplorer
End Sub

Public Sub Class_Terminate()
    Set aehMailItem = Nothing
    Set aehExp = Nothing
    Set aehApp = Nothing
End Sub

Public Sub aehExp_SelectionChange()
    ' Event triggers when any selection change occurs
    ' Select a mail item in the left pane triggers this event twice, not sure why
    Dim obj As Object
    On Error Resume Next
    ' The following line causes an Out of Bounds error on startup, but is fine otherwise,
    ' which is why the above 'On Error Resume Next' is required.
    Set obj = aehExp.Selection.Item(1)
    Select Case obj.Class
        Case Is = olMail ' It's a MailItem! (Class 43)
            Set aehMailItem = obj
            Debug.Print aehMailItem.To
    End Select
End Sub

Public Sub aehMailItem_Forward(ByVal Response As Object, Cancel As Boolean)
    ' Event triggers when Reply is selected.

    If InStr(aehMailItem.body, "Specific text in signature") > 0 Then
        InsertSignature "Internal.htm"
    Else
        InsertSignature "External.htm"
    End If

End Sub

Public Sub aehMailItem_Reply(ByVal Response As Object, Cancel As Boolean)
    ' Event triggers when Reply is selected.

    If InStr(aehMailItem.body, "Specific text in signature") > 0 Then
        InsertSignature "Internal.htm"
    Else
        InsertSignature "External.htm"
    End If

End Sub

Public Sub aehMailItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
    ' Event triggers when Reply is selected.

    If InStr(aehMailItem.body, "Specific text in signature") > 0 Then
        InsertSignature "Internal.htm"
    Else
        InsertSignature "External.htm"
    End If

End Sub

Public Sub aehMailItem_Open(Cancel As Boolean)
    Dim xRecipients As Recipients
    Dim xRecipient As Recipient
    Dim xRcpAddress As String
    If Item.Class <> olMail Then Exit Sub
    Set xRecipients = aehMailItem.Recipients
    For Each xRecipient In xRecipients
    If xRecipient.AddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Then
        xRcpAddress = xRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
    Else
        xRcpAddress = xRecipient.AddressEntry.Address
    End If
    If InStr(xRcpAddress, "@company.com") Then
        InsertSignature ("Internal.htm")
    Else
        InsertSignature ("External.htm")
    End If
Next
End Sub
Sub InsertSignature(SigName As String)
    ' Requires reference to Microsoft Scripting Runtime (Tools > References..., then check 'Microsoft Scripting Runtime')
    Dim xSignaturePath As String
    xSignaturePath = SignaturePath(SigName)
    Dim fso As Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
    If fso.FileExists(xSignaturePath) Then
        Dim ts As Scripting.TextStream: Set ts = fso.OpenTextFile(xSignaturePath)
        Dim Signature As String: Signature = ts.ReadAll
        Dim aeh As AppEventsHandler
        Set aeh = New AppEventsHandler
        Dim mi As mailItem
        Set mi = Outlook.ActiveExplorer.Selection.Item(1)
        mi.HTMLBody = Signature & mi.HTMLBody
    End If
End Sub

 Function SignaturePath(SigName As String)
    Dim xSignatureFile As String
    Dim GFSO As Scripting.FileSystemObject
    Dim GTextStream As Scripting.TextStream
    Dim GText As String
    Set GFSO = New Scripting.FileSystemObject
    xSignatureFile = CreateObject("WScript.Shell").SpecialFolders(5)
    xSignatureFile = xSignatureFile & "\Microsoft\Signatures\" & SigName
    Set GTextStream = GFSO.OpenTextFile(xSignatureFile)
    GText = ""
    GText = GTextStream.ReadAll
    SignaturePath = GText
End Function

我觉得这对我正在寻找的东西来说是一个非常好的结构，但我无法让任何东西正常工作。另外，我不确定如何主动查看电子邮件将发送给谁。同样，我对 VBA 知之甚少，但通过研究我认为使用 SetFocus 是我想要的。我见过其他人使用 ItemSend 事件来实现类似的目的。我试图避免使用它，因为我希望用户在发送之前看到签名，并且因为如果您在回复或转发时使用 ItemSend，它将在回复链的最底部添加签名，而不是您的实际回复。对此的任何帮助或意见都会很棒！

标签： vbaoutlook

vba - 根据收件人主动更改电子邮件签名

问题描述

解决方案

推荐阅读