excel - 将 Excel 范围内的超链接传输到 Outlook 电子邮件

Question

我正在尝试从 excel 范围(rng 1 到 6)创建一封电子邮件，其中包含 A 列和 D 列中每个单元格的超链接。这是为这些范围创建超链接的代码示例。这一切都很好。

ActiveSheet.Hyperlinks.Add Anchor:=ActiveWorkbook.Sheets("Overdue").Range("A" & D2), _
Address:="some address" & ActiveWorkbook.Sheets("Overdue").Range("A" & D2).Value 

ActiveSheet.Hyperlinks.Add Anchor:=ActiveWorkbook.Sheets("Overdue").Range("D" & D2), _
Address:="some other address" & ActiveWorkbook.Sheets("Overdue").Range("A" & D2).Value

然后我有下面的代码，它从 excel 范围(rng1 到 6)创建一封电子邮件。创建电子邮件时，超链接不会传输到 Outlook。文本带有下划线，就好像有一个超链接，但它是不可点击的。

Sub Mail_Body()
Dim rng1 As Range
Dim OutApp As Object
Dim OutMail As Object
Dim wb2 As Workbook
Dim MyDate, Weeknr, MyFileName, MyTime, MyMonth
Dim Mail1 As String
Dim Mail2 As String
Dim Subject As String
Dim Warr As String
Dim rng2 As Range
Dim rng3 As Range
Dim rng4 As Range
Dim rng5 As Range
Dim rng6 As Range
Dim Subject_email As String

Application.ScreenUpdating = False
Application.EnableEvents = False

nPath = Environ("temp") & "\" & ThisWorkbook.Sheets("Lists").Range("AA1").Value
Set wb2 = Workbooks.Open(nPath)

D2 = Sheets("Critical").Range("A1").Offset(Sheets("Critical").Rows.Count - 1, 0).End(xlUp).Row
D3 = Sheets("High").Range("A1").Offset(Sheets("High").Rows.Count - 1, 0).End(xlUp).Row
D4 = Sheets("Low").Range("A1").Offset(Sheets("Low").Rows.Count - 1, 0).End(xlUp).Row
D5 = Sheets("Other").Range("A1").Offset(Sheets("Other").Rows.Count - 1, 0).End(xlUp).Row
D6 = Sheets("Overdue").Range("A1").Offset(Sheets("Overdue").Rows.Count - 1, 0).End(xlUp).Row

Set rng = Nothing
Set rng1 = Nothing
Set rng2 = Nothing
Set rng3 = Nothing
Set rng4 = Nothing
Set rng5 = Nothing
Set rng6 = Nothing

Set rng2 = Sheets("Critical").Range("A1:J" & D2).SpecialCells(xlCellTypeVisible)
Set rng3 = Sheets("High").Range("A1:J" & D3).SpecialCells(xlCellTypeVisible)
Set rng4 = Sheets("Low").Range("A1:J" & D4).SpecialCells(xlCellTypeVisible)
Set rng5 = Sheets("Other").Range("A1:J" & D5).SpecialCells(xlCellTypeVisible)
Set rng6 = Sheets("Overdue").Range("A1:L" & D6).SpecialCells(xlCellTypeVisible)

Set OutMail = Nothing
Set OutApp = Nothing

On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
'MsgBox OutApp
Set OutMail = OutApp.CreateItem(0)

Dim Session As Object
Set Session = OutApp.GetNamespace("MAPI")
Session.Logon

Create email
With OutMail
    .To = Mail1
    .CC = Mail2
    .BCC = ""
    .Subject = Subject_email
    .HTMLBody = "Overview:" & "<br>" & RangetoHTML(rng1) _
       & "<br>" & "<u>Critical</u>" & "<br>" & RangetoHTML(rng2) & "<br>"   & "<u>High</u>" _
        & "<br>" & RangetoHTML(rng3) & "<br>" & "<u>Low</u>" & "<br>" &  RangetoHTML(rng4) _
        & "<br>" & "<u>Other</u>" & "<br>" & RangetoHTML(rng5) _
        & "<br>" & "<u>Overdue</u>" & "<br>" & RangetoHTML(rng6)
    .Attachments.Add nPath '.FullName
    .Recipients.ResolveAll
    .Display  '.Send
End With

我无法共享此代码的输出，但是如上所述，Excel 工作表中的超链接不会传输到 Outlook 电子邮件。它们是蓝色的并带有下划线，但没有超链接。
如何将事件超链接从 excel 转移到 Outlook？我一直无法找到适合我特定需求的现有解决方案。

Answer 1

我找到了解决问题的方法:https://www.mrexcel.com/forum/excel-questions/560111-retain-hyperlinks-after-rangetohtml-paste-outlook.html

在 RangetoHTML 函数中，将 .pastevalues 更改为 .pasteall，超链接将被复制过来。

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim r As Long

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 xlPasteAll, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).PasteSpecial xlPasteRowHeights
    .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 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