VBA Outlook Signature Image

问题

I'm trying to change outlook email signatures automatically depending on a specific keyword on the subject.

On my first try I added the signature at the bottom of the email.

The signature came perfect including image and all but that there was an issue with the placement as the signature was appended at the very bottom of the email below the original text.

On my second try I set up a default signature that works as a placeholder. The macro then finds the placeholder and replaces it with the correct signature. The macro works and inserts the signature in the correct location but now the signature image is not showing up.

A couple weird things with the issue:

Image issue occurs only when composing new email. Image comes in correctly when replying or forwarding.
Signature looks okay on sender's outlook client (i.e. image is displayed before sending email).

Signature is not displayed on recipient's outlook client (tried outlook and iOS mail).

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

来源：https://stackoverflow.com/questions/60066510/vba-outlook-signature-image

标签

vba

outlook