使用 Excel 中的 RangetoHTML 时如何在电子邮件正文中保留/保留超链接

Question

我正在使用 Ron de Bruin 的 RangetoHTML 示例从 Excel 中当前工作表上的选择中发送电子邮件。一切正常，但是包含超链接的工作表的两列以纯文本形式出现（并且不可点击）。
我进一步尝试实施来自Mail range with formatting through vba in excel 的建议并添加了“For Each HyperL”循环，但令人惊讶的是，整个电子邮件正文完全为空。我可以看到临时文件不是空的，但是那里的超链接也已经丢失了。

下面是我的例子 - 非常感谢我做错了什么！

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim Hlink As Hyperlink

    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 Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    For Each Hlink In rng.Hyperlinks
        TempWB.Sheets(1).Hyperlinks.Add _
        Anchor:=TempWB.Sheets(1).Range(Hlink.Range.Address), _
        Address:=Hlink.Address, _
        TextToDisplay:=Hlink.TextToDisplay
    Next Hlink
 

    '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

这里是调用子程序代码：

Sub SendBugReport()
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object

    Set wb = ActiveWorkbook
    Set Source = Nothing
    On Error Resume Next
    Set Source = Selection.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
            .to = Sheets("Email Subject and Dlist").Range("B1").Value
            .CC = ""
            .BCC = ""
            .Subject = Sheets("Email Subject and Dlist").Range("B5").Value
            .HTMLBody = RangetoHTML(Source)
            .Display
    End With
    On Error GoTo 0
    '    .Close savechanges:=False
 
    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Answer 1

我遇到了following link，它会对此有所帮助。

作为总结，在RangeToHTML() 中添加以下内容就足够了：

在顶部：

Dim Hlink As Hyperlink

就在发布代码之前：

For Each Hlink In rng.Hyperlinks
TempWB.Sheets(1).Hyperlinks.Add _
Anchor:=TempWB.Sheets(1).Range(Hlink.Range.Address), _
Address:=Hlink.Address, _
TextToDisplay:=Hlink.TextToDisplay
Next Hlink