Изображение подписи VBA Outlook - PullRequest
Новая
       8

Изображение подписи VBA Outlook

1 голос
/ 05 февраля 2020

Я пытаюсь автоматически менять подписи Outlook в зависимости от указанного c ключевого слова по теме.

С первой попытки я добавил подпись внизу письма.

Подпись была идеальной, включая изображение и все, кроме того, что была проблема с размещением, так как подпись была добавлена ​​в самом низу электронного письма ниже исходного текста.

Со второй попытки я устанавливаю подпись по умолчанию, которая работает как заполнитель. Затем макрос находит заполнитель и заменяет его правильной подписью. Макрос работает и вставляет подпись в правильное место, но теперь изображение подписи не отображается.

Пара странных вещей с проблемой:

  • Проблема с изображением возникает только при создании новой электронной почты. Изображение приходит правильно при ответе или пересылке.

  • Подпись выглядит нормально на клиенте Outlook отправителя (т.е. изображение отображается перед отправкой электронной почты).

Подпись не отображается на клиенте Outlook получателя (пробный Outlook и iOS почта). 

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objMail As Outlook.MailItem
    Dim strSignatureFile As String
    Dim objFileSystem As Object
    Dim objTextStream As Object
    Dim strSignature As String
    Dim sPath As String

    If TypeOf Item Is MailItem Then
       Set objMail = Item
       emailSubject = "T " & LCase(objMail.Subject)
    End If

    test = "keyWord"
    If InStr(emailSubject, test) = 0 Then
        sPath = Environ("appdata") & "\Microsoft\Signatures\signature1.htm"
        signImageFolderName = "signature1_files"
    Else
        sPath = Environ("appdata") & "\Microsoft\Signatures\signature2.htm"
        signImageFolderName = "signature2_files"
    End If

    completeFolderPath = Environ("appdata") & "\Microsoft\Signatures\" & signImageFolderName

    If Dir(sPath) <> "" Then
        strSignature = GetSignature(sPath)
        ' Now replace this incomplete file path
        ' with complete path wherever it is used
        strSignature = VBA.Replace(strSignature, signImageFolderName, completeFolderPath)
    Else
        strSignature = ""
    End If

    'Insert the signature to this email
    bodySignature = "<HTML><BODY><br>" & strSignature & "</br></HTML></BODY>"
    objMail.HTMLBody = Replace(objMail.HTMLBody, "SingaturePlaceHolder", bodySignature)


End Sub
Function GetSignature(fPath As String) As String
    Dim fso As Object
    Dim TSet As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set TSet = fso.GetFile(fPath).OpenAsTextStream(1, -2)
    GetSignature = TSet.readall
    TSet.Close
End Function
...