How to preserve/retain hyperlinks in email body when using RangetoHTML from Excel

Question

I am using Ron de Bruin's RangetoHTML example to send email from selection on current worksheet in Excel. All working perfectly, however the two columns of the sheet that contain hyperlinks are coming as plain text (and are not clickable). I further tried to implement the suggestion from Mail range with formatting through vba in excel and added the "For Each HyperL" loop, but after doing that surprisingly the whole email body comes out completely empty. I can see that the temp file is not empty, but the hyperlinks are already missing there too.

below is my example - much appreciating ideas on what I have done wrong!

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

Here is the calling subroutine code:

code Sub SendBugReport() Dim Source As Range Dim Dest As Workbook Dim wb As Workbook Dim TempFilePath As String Dim TempFileName As String Dim FileExtStr As String Dim FileFormatNum As Long 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

I don't see anything there about email. Can you post the full code. — GavinP
Actually added the subroutine code in the original question description — Evelina
Thanks. I had hoped you were just using .Body instead of .HTMLBody. I'm wondering if you're over complicating it with the htm file creation etc. Is the only value in the 2 columns a link? Could you simply iterate through the range creating the email body a line at a time, in a table adding the required HTML tags? — GavinP
@GavinP, thanks for reply - I saw this suggestion in another post, but I am not finding it easier or more simple to run a double cycle and add html tags manually. I have 2 columns at this time that hold hyperlinks. Isn't there a way to make it work with the above approach? Thanks so much! — Evelina

Prakash Krishnan Prakash Krishnan · Accepted Answer · 2017-01-12T12:23:01

I came across the following link which will help in this.

As a summary, adding the following in RangeToHTML() will suffice:

At the top:

Dim Hlink As Hyperlink

Just before publish code:

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

How to preserve/retain hyperlinks in email body when using RangetoHTML from Excel

1 Answers