Excel VBA - конвертировать диапазон с изображениями и кнопками в HTML

Question

Я написал функцию, которая превращает диапазон Excel в HTML для дальнейшего использования в теле письма.Проблема в том, что теперь я хочу добавить изображения и кнопки в диапазон, а затем перенести их в тело письма.

Как мне добиться успеха, чтобы обращаться к объектам в диапазоне и также преобразовывать их?

Спасибо

Диапазон функций до 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

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"), "someemail@someserver.com", "Some Subject"
End Sub