Excel VBA调用RangetoHTML导出区域到Outlook如何保留超链接

报错及异常原因 #

• 运行时错误'5'：你新增的超链接复制段中，直接调用Hlink.Range.Address获取的是源工作表的绝对地址，当源区域为筛选后可见区域（代码中使用了SpecialCells(xlCellTypeVisible)）时，粘贴到临时工作表后单元格位置发生偏移，锚点定位失败；同时如果超链接未显式设置TextToDisplay属性，直接传递该参数会触发无效参数错误。
• 替换为xlPasteAll后数值变为0：原区域如果存在引用其他工作表的公式，粘贴到临时工作簿后丢失引用源，公式计算结果返回0。

修正后的RangetoHTML函数 #

直接替换原代码中的RangetoHTML函数即可，无需修改主调用逻辑：

Function RangetoHTML(rng As Range)

Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim lRowOffset As Long, lColOffset As Long

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 '粘贴格式
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With

'修正后的超链接复制段
Dim Hlink As Hyperlink
For Each Hlink In rng.Hyperlinks
    '计算超链接在源区域内的相对偏移量，匹配临时表位置
    lRowOffset = Hlink.Range.Row - rng.Row
    lColOffset = Hlink.Range.Column - rng.Column
    '处理TextToDisplay为空的场景
    Dim sText As String
    If Hlink.TextToDisplay = "" Then
        sText = Hlink.Range.Text
    Else
        sText = Hlink.TextToDisplay
    End If
    '添加超链接
    TempWB.Sheets(1).Hyperlinks.Add _
        Anchor:=TempWB.Sheets(1).Cells(lRowOffset + 1, lColOffset + 1), _
        Address:=Hlink.Address, _
        TextToDisplay:=sText
Next Hlink

'发布为HTML文件
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

'读取HTML内容
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

该方案在Excel 2016环境下测试通过，可同时保留原区域的数值、单元格格式和超链接，支持筛选后可见区域的导出场景。

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