使用Excel VBA

Question

我想添加带图像的签名。这里的图片是指公司徽标和社交网络图标。

此代码是用Excel VBA编写的，目标是将范围粘贴为Outlook电子邮件中的图片。

Dim Rng                     As Range
Dim outlookApp              As Object
Dim outMail                 As Object

Dim wordDoc                 As Word.Document
Dim LastRow                 As Long
Dim CcAddress               As String
Dim ToAddress               As String
Dim i                       As Long
Dim EndRow                  As String

Dim Signature               As String

'// Added Microsoft word reference

Sub Excel_Image_Paste_Testing()

    On Error GoTo Err_Desc

    '\\ Define Endrow
    EndRow = Range("A65000").End(xlUp).Row

    '\\ Range for copy paste as image
    Set Rng = Range("A22:G" & EndRow)
    Rng.Copy

    '\\ Open a new mail item
    Set outlookApp = CreateObject("Outlook.Application")
    Set outMail = outlookApp.CreateItem(0)

    '\\ Display message to capture signature
    outMail.Display

    '\\ This doesnt store images because its defined as string
    'Problem lies here
    Signature = outMail.htmlBody

    '\\ Get its Word editor
    Set wordDoc = outMail.GetInspector.WordEditor
    outMail.Display

    '\\ To paste as picture
    wordDoc.Range.PasteAndFormat wdChartPicture

    '\\ TO and CC Address
    CcAddress = "xyz@gmail.com"
    ToAddress = "abc@gmail.com"

    '\\ Format email
    With outMail
        .htmlBody = .htmlBody & Signature
        .Display
        .To = ToAddress
        .CC = CcAddress
        .BCC = ""
        .Subject = "Email Subject here"
        .readreceiptrequested = True
    End With

    '\\ Reset selections
    Application.CutCopyMode = False
    Range("B1").Select

    Exit Sub
Err_Desc:
    MsgBox Err.Description

End Sub

此文件将分发给许多人。我不知道默认的.htm签名名称。

（“应用程序数据\漫游\微软\签名”）

人们也可能有很多签名，但我的目标是捕获他们的默认签名。

运行代码后的错误签名图片

我的签名应如下所示

Answer 1

在此代码中，我们将让用户从.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@email.com" '<~~ 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

在行动