Я пытаюсь создать макрос, который будет активно изменять / обновлять подпись электронной почты пользователей в зависимости от адресов в строках «Кому», CC и B CC. У меня есть 2 стиля подписи: «Internal.htm» для писем, отправленных внутри моей компании, и «External.htm» для писем, отправленных за пределами компании, но только для первого сообщения внешнему пользователю. Если в цепочке писем уже есть «внешняя» подпись, будет использоваться «внутренняя». Таким образом, при создании нового электронного письма подпись по умолчанию будет отображаться как «Внешняя», и если вы введете адрес электронной почты для кого-то внутри компании, тогда подпись изменится на «Внутреннюю».
I ' мне удалось найти фрагменты кода с различных сайтов, которые довольно близки к тому, что я ищу, но, поскольку я новичок в 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 для ответа или пересылки, он добавит подпись в самом низу цепочки ответов, а не с вашим актуальный ответ. Любая помощь или информация по этому поводу были бы замечательными!