excel - Excel VBA - 将带有图片和按钮的范围转换为 HTML

Question

我编写了一个函数，可以将 excel 范围转换为 HTML，以便在电子邮件正文中进一步使用。问题是我现在想将图片和按钮添加到该范围，然后将其接管到电子邮件正文中。

我如何才能获得 excel 来处理范围内的对象并将它们转换过来？

谢谢

函数范围到 HTML

    Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook


    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"


    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With


    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With


    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")


    'Close TempWB
    TempWB.Close savechanges:=False


    'Delete the htm file we used in this function
    Kill TempFile


    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function

标签： excelvba

Answer 1

正如我在上面的评论中提到的，将范围和对象复制到新工作簿，然后将工作簿保存为 html。读取字符串中的 html 文件，然后在.HTMLBody稍作更改后将其设置为该字符串。

重要：

1. 将 html 文件保存在一个空文件夹中。我将包含代码和数据的excel文件粘贴在一个空文件夹中。
2. 在 Excel 2013 中测试

假设我们的工作簿看起来像这样

请参阅下面的代码。我已经对代码进行了注释，因此您理解它应该没有问题。仍然，如果您这样做，则回发。

代码：

Option Explicit

'~~> This is the temp html file name.
'~~> Do not change this as when you publish the
'~~> html file, it will create a folder Temp_files
'~~> to store the images
Const tmpFile As String = "Temp.Htm"

'~~> Do not change "Myimg". This will be used to
'~~> identify the images
Const imgPrefix As String = "Myimg"

Sub Sample()
    Dim wbThis As Workbook, wbNew As Workbook
    Dim tempFileName As String, imgName As String, newPath As String

    Set wbThis = ThisWorkbook
    Set wbNew = Workbooks.Add

    '~~> Copy the relevant range to new workbook
    wbThis.Sheets("Sheet1").Range("A1:J17").Copy _
    wbNew.Worksheets("Sheet1").Range("A1")

    newPath = ThisWorkbook.Path & "\"
    tempFileName = newPath & tmpFile

    '~~> Publish the image
    With wbNew.PublishObjects.Add(xlSourceRange, _
        tempFileName, "Sheet1", "$A$1:$J$17", xlHtmlStatic, _
        imgPrefix, "")
        .Publish (True)
        .AutoRepublish = True
    End With

    '~~> Close the new file without saving
    wbNew.Close (False)

    '~~> Read the html file in a string in one go
    Dim MyData As String, strData() As String
    Dim i As Long
    Open tempFileName For Binary As #1
    MyData = Space$(LOF(1))
    Get #1, , MyData
    Close #1
    strData() = Split(MyData, vbCrLf)

    '~~> Loop through the file
    For i = LBound(strData) To UBound(strData)
        '~~> Here we will first get the image names
        If InStr(1, strData(i), "Myimg_", vbTextCompare) And InStr(1, strData(i), ".Png", vbTextCompare) Then
            '~~> Insert actual path to the images
            strData(i) = Replace(strData(i), "Temp_files/", newPath & "Temp_files\")
        End If
    Next i

    '~~> Rejoin to get the new html string
    MyData = Join(strData, vbCrLf)

    '~~> Create the Email
    Dim OutApp As Object, OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = "Email address Goes here"
        .Subject = "Subject Goes here"

        '~~> Set the body
        .HTMLBody = MyData

        '~~> Show the email. Change it to `.Send` to send it
        .Display
    End With

    '~~> Delete the temp file name
    Kill tempFileName
End Sub

输出：

---

将其转换为函数

Option Explicit

Private Function RngToEmail(rng As Range, eTo As String, eSubject As String)
    Dim wbThis As Workbook, wbNew As Workbook
    Dim tempFileName As String, imgName As String, newPath As String

    '~~> Do not change "Myimg". This will be used to
    '~~> identify the images
    Dim imgPrefix As String: imgPrefix = "Myimg"

    '~~> This is the temp html file name.
    '~~> Do not change this as when you publish the
    '~~> html file, it will create a folder Temp_files
    '~~> to store the images
    Dim tmpFile As String: tmpFile = "Temp.Htm"

    Set wbThis = Workbooks(rng.Parent.Parent.Name)
    Set wbNew = Workbooks.Add

    '~~> Copy the relevant range to new workbook
    rng.Copy wbNew.Worksheets("Sheet1").Range("A1")

    newPath = wbThis.Path & "\"
    tempFileName = newPath & tmpFile

    '~~> Publish the image
    With wbNew.PublishObjects.Add(xlSourceRange, _
        tempFileName, "Sheet1", Rng.Address, xlHtmlStatic, _
        imgPrefix, "")
        .Publish (True)
        .AutoRepublish = True
    End With

    '~~> Close the new file without saving
    wbNew.Close (False)

    '~~> Read the html file in a string in one go
    Dim MyData As String, strData() As String
    Dim i As Long
    Open tempFileName For Binary As #1
    MyData = Space$(LOF(1))
    Get #1, , MyData
    Close #1
    strData() = Split(MyData, vbCrLf)

    '~~> Loop through the file
    For i = LBound(strData) To UBound(strData)
        '~~> Here we will first get the image names
        If InStr(1, strData(i), "Myimg_", vbTextCompare) And InStr(1, strData(i), ".Png", vbTextCompare) Then
            '~~> Insert actual path to the images
            strData(i) = Replace(strData(i), "Temp_files/", newPath & "Temp_files\")
        End If
    Next i

    '~~> Rejoin to get the new html string
    MyData = Join(strData, vbCrLf)

    '~~> Create the Email
    Dim OutApp As Object, OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .to = eTo
        .subject = eSubject

        '~~> Set the body
        .HTMLBody = MyData

        '~~> Show the email. Change it to `.Send` to send it
        .Display
    End With

    '~~> Delete the temp file name
    Kill tempFileName
End Function

用法：

Sub Sample()
    RngToEmail ThisWorkbook.Sheets("Sheet1").Range("A1:J17"), "[e-mail]", "Some Subject"
End Sub