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

76
10

Я написал функцию, которая превращает диапазон 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

спросил(а) 2019-01-04T08:00:00+03:00 2 года, 3 месяца назад
1
Решение
75

Как я уже упоминал в комментариях выше, скопируйте диапазон и объект в новую книгу, а затем сохраните книгу в виде HTML. Прочитайте html файл в строке и затем установите .HTMLBody в эту строку после небольшого изменения.

Важно:

Сохраните HTML файл в пустой папке. Я вставил файл Excel, который содержит код и данные, в пустую папку. Проверено в Excel 2013

Допустим, наша книга выглядит так

enter image description here

Смотрите код ниже. Я прокомментировал код, чтобы у вас не было проблем с его пониманием. Тем не менее, если вы делаете, то отправьте обратно.

Код:

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

Выход:

enter image description here

Преобразовал его в функцию

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

ответил(а) 2019-01-04T12:00:00+03:00 2 года, 3 месяца назад
Ваш ответ
Введите минимум 50 символов
Чтобы , пожалуйста,
Выберите тему жалобы:

Другая проблема