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

这是调用子程序代码：

code Sub SendBugReport（）昏暗的来源作为范围 Dim Dest As Workbook Dim wb As Workbook Dim TempFilePath As String Dim TempFileName As String Dim FileExtStr As String 昏暗的FileFormatNum长 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

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

1 个答案: