从Excel发送电子邮件：RangetoHTML现有工作表而不是新工作簿

Question

I've been using the RangetoHTML function that can be found on Microsofts webpage. I've tried to modify it to using an existing sheet in the active workbook instead of creating a new workbook each time, however when the email is created, the bodytext is not copied in the email. It works with the original function, so I figured the error must be in the RangeToHTML function:

Function RangetoHTML(BodyText As Range)
' Working in Office 2000-2013
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim DraftWS As Worksheet

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
BodyText.Copy
Set TempWB = ThisWorkbook
Set DraftWS = ThisWorkbook.Worksheets(Sheet17.Name)

With DraftWS
    .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 DraftWB.PublishObjects.Add( _
     SourceType:=xlSourceRange, _
     Filename:=TempFile, _
     Sheet:=DraftWS.Name, _
     Source:=DraftWS.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
'DraftWS.Cells.Clear

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


Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
Set DraftWS = Nothing
End Function

Answer 1

Try this. Worked for me.

Option Explicit

Sub test()
    Debug.Print RangetoHTML(Range("A1:K5"))
End Sub

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

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

    'Copy the range and create a new worksheet to past the data in
    rng.Copy
    Set TempWS = ActiveWorkbook.Sheets.Add
    With TempWS
        .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 ActiveWorkbook.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWS.Name, _
         Source:=TempWS.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=")

    'Delete TempWS
    Application.DisplayAlerts = False
    TempWS.Delete
    Application.DisplayAlerts = True

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

    Set ts = Nothing
    Set fso = Nothing
    Set TempWS = Nothing
End Function