使用Excel VBA在Outlook中添加包含图像的默认签名

在此代码中，我们将允许用户从中选择.Htm文件AppData\Roaming\Microsoft\Signatures

问题是我们不能直接使用该文件的html主体，因为图像存储在另一个文件夹中filename_files，如下所示。

htmlbody中提到的路径也不完整。看下面的图片

这是我编写的一个快速函数，它将修复html正文中的路径

'~~> Function to fix image paths in Signature .htm Files
Function FixHtmlBody(r As Variant) As String
    Dim FullPath As String, filename As String
    Dim FilenameWithoutExtn As String
    Dim foldername As String
    Dim MyData As String

    '~~> Read the html file as text file in a string variable
    Open r For Binary As #1
    MyData = Space$(LOF(1))
    Get #1, , MyData
    Close #1

    '~~> Get File Name from path
    filename = GetFilenameFromPath(r)
    '~~> Get File Name without extension
    FilenameWithoutExtn = Left(filename, (InStrRev(filename, ".", -1, vbTextCompare) - 1))
    '~~> Get the foldername where the images are stored
    foldername = FilenameWithoutExtn & "_files"
    '~~> Full Path of Folder
    FullPath = Left(r, InStrRev(r, "\")) & foldername

    '~~> Replace incomplete path with full Path
    FixHtmlBody = Replace(MyData, foldername, FullPath)
End Function

这是完整的过程。我已经注释了代码。让我知道您是否还有任何问题。

Sub Sample()
    Dim oOutApp As Object, oOutMail As Object
    Dim strbody As String, FixedHtmlBody As String
    Dim Ret

    '~~> Ask user to select the htm file
    Ret = Application.GetOpenFilename("Html Files (*.htm), *.htm")

    If Ret = False Then Exit Sub

    '~~> Use the function to fix image paths in the htm file
    FixedHtmlBody = FixHtmlBody(Ret)

    Set oOutApp = CreateObject("Outlook.Application")
    Set oOutMail = oOutApp.CreateItem(0)

    strbody = "<H3><B>Dear Blah Blah</B></H3>" & _
              "More Blah Blah<br>" & _
              "<br><br><B>Thank you</B>" & FixedHtmlBody

    On Error Resume Next
    With oOutMail
        .To = "[email protected]" '<~~ Change as applicable
        .CC = ""
        .BCC = ""
        .Subject = "Example on how to insert image in signature"
        .HTMLBody = .HTMLBody & "<br>" & strbody
        .Display
    End With
    On Error GoTo 0

    Set oOutMail = Nothing
    Set oOutApp = Nothing
End Sub

'~~> Function to fix image paths in Signature .htm Files
Function FixHtmlBody(r As Variant) As String
    Dim FullPath As String, filename As String
    Dim FilenameWithoutExtn As String
    Dim foldername As String
    Dim MyData As String

    '~~> Read the html file as text file in a string variable
    Open r For Binary As #1
    MyData = Space$(LOF(1))
    Get #1, , MyData
    Close #1

    '~~> Get File Name from path
    filename = GetFilenameFromPath(r)
    '~~> Get File Name without extension
    FilenameWithoutExtn = Left(filename, (InStrRev(filename, ".", -1, vbTextCompare) - 1))
    '~~> Get the foldername where the images are stored
    foldername = FilenameWithoutExtn & "_files"

    '~~> Full Path of Folder
    FullPath = Left(r, InStrRev(r, "\")) & foldername

    '~~> To cater for spaces in signature file name
    FullPath = Replace(FullPath, " ", "%20")

    '~~> Replace incomplete path with full Path
    FixHtmlBody = Replace(MyData, foldername, FullPath)
End Function

'~~> Gets File Name from path
Public Function GetFilenameFromPath(ByVal strPath As String) As String
    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then _
    GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End Function

行动中