Transfer Hyperlinks in Excel Range to Outlook Email

Question

I am trying to create an email from excel ranges (rng 1 through 6) that have hyperlinks for each cell in Columns A and D. Here is an example of the code that creates the hyperlinks for these ranges. That all works just fine.

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

I then have the below code that creates an email from the excel ranges (rng1 through 6). When the email is created the hyperlinks do not transfer to Outlook. The text is underlined as if there is a hyperlink but it is not clickable.

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

I'm unable to share the output of this code, but what happens, as explained above, is the hyperlinks from the Excel sheet do not transfer to the Outlook email. They are blue and underlined but there is no hyperlink.
How do I carry over the active hyperlinks from excel to outlook? I've been unable to find a pre-existing solution that fits my specific needs.

Answer 1

I found a solution to the issue: https://www.mrexcel.com/forum/excel-questions/560111-retain-hyperlinks-after-rangetohtml-paste-outlook.html

In the RangetoHTML function, change the .pastevalues to .pasteall and the hyperlinks will be copied over.

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