Excel VBA-将带有图片和按钮的范围转换为HTML [英] Excel VBA - convert range with pictures and buttons to HTML

问题描述

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

I wrote a function that turns an excel range into HTML for further use in an email body. The problem is that I now want to add pictures and buttons to the range and have it then taken over into the email body.

我如何才能使excel处理范围内的对象并将其转换过来?

How I can get excel to address objects in the range and convert them over as well?

谢谢

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

推荐答案

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

As I mentioned in the comments above, copy the range and the object to a new workbook and then save the workbook as an html. Read the html file in a string and then set the .HTMLBody to that string after making a slight change.

重要:

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

假设我们的工作簿是这样的

Let's say our workbook looks like this

请参见下面的代码.我已经注释了该代码，因此您在理解它时应该不会有问题.如果您仍然这样做，则发回.

See the code below. I have commented the code so you should not have a problem understanding it. Still if you do then post back.

代码:

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

这篇关于Excel VBA-将带有图片和按钮的范围转换为HTML的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！