如何在HTML邮件中保留Excel区域内的超链接？

我从别处找到了这段VBA代码，用来将Excel区域内容转成HTML插入邮件，区域里的表格有一列带超链接，但转成HTML后超链接只显示成蓝色下划线文本，无法点击跳转。尝试修改HtmlType:=xlHtmlStatic为其他值还出现了错误。

原代码如下：

Function RangetoHTML(rng As Range)

    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"
    
    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
    
    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

    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=")
    
    TempWB.Close savechanges:=False
    
    Kill TempFile

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

问题根源 #

原代码的粘贴步骤只复制了值和格式，没有完整保留超链接的可跳转属性；另外xlHtmlStatic生成的静态HTML中，Excel会用非标准的xlink:href标签定义超链接，多数邮件客户端不识别这个属性，导致超链接无法点击。

解决方案1：修改原代码保留超链接并修复HTML标签 #

替换粘贴方式，完整保留原区域的超链接，同时将非标准的超链接标签替换为邮件客户端兼容的标准格式：

Function RangetoHTML(rng As Range)

    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"
    
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        ' 替换多次粘贴为一次性粘贴全部内容，保留超链接
        .Cells(1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    With TempWB.PublishObjects.Add( _
      SourceType:=xlSourceRange, _
      Filename:=TempFile, _
      Sheet:=TempWB.Sheets(1).Name, _
      Source:=TempWB.Sheets(1).UsedRange.Address, _
      HtmlType:=xlHtmlStatic) ' 保持静态，避免依赖Excel文件
        .Publish (True)
    End With

    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=")
    ' 将Excel生成的非标准xlink:href替换为标准href，确保邮件客户端识别
    RangetoHTML = Replace(RangetoHTML, "xlink:href=", "href=")
    
    TempWB.Close savechanges:=False
    
    Kill TempFile

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

解决方案2：利用Word对象生成兼容邮件的HTML #

如果方案1仍有兼容性问题，可以借助Word的粘贴和HTML导出功能，它生成的超链接格式更符合邮件客户端的要求：

Function RangetoHTML(rng As Range)
    Dim objWord As Object
    Dim objDoc As Object
    Dim TempFile As String
    
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    ' 创建Word应用对象
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = False ' 后台运行不显示界面
    Set objDoc = objWord.Documents.Add
    
    ' 将Excel区域粘贴到Word，保留表格和超链接
    rng.Copy
    objDoc.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
    
    ' 保存为HTML格式（wdFormatHTML对应数值8）
    objDoc.SaveAs2 Filename:=TempFile, FileFormat:=8
    objDoc.Close SaveChanges:=False
    objWord.Quit
    
    ' 读取生成的HTML内容
    Dim fso As Object, ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    
    ' 清理临时文件和对象
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set objDoc = Nothing
    Set objWord = Nothing
End Function

内容的提问来源于stack exchange，提问作者d wattam