Hyperlink not working using Range to HTML function - html

Question

Using some VBA to grab a table of information and paste to the body of an email using range to html. The problem seems to be with the hyperlink, since the function is just grabbing it as text and formatting it accordingly. The vba i'm using is:
Sub Archive_Send()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody1 As Range
Dim StrBody As String
Dim StrBody1 As String
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Posting").Range("B5:C55").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set rngTo = Sheets("Email").Range("C5")
Set rngSubject = Sheets("Email").Range("C3")
Set rngBody1 = Sheets("Email").Range("C13")
On Error Resume Next
With OutMail
.To = rngTo.Value
.Subject = rngSubject.Value
.HTMLBody = .HTMLBody & rngBody1.Value & "" _
& RangetoHTML(rng) _
& "<br><br>Best Regards,<br><br></font></span>"
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Application.ReferenceStyle = xlA1
End Sub
Function RangetoHTML(rng As Range)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy") & ".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
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
On Error GoTo 0
End With
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
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

Answer 1

The code rangetohtml works for me with hyperlinks just after making little change shown below:
Use .Cells(1).PasteSpecial xlPasteAll, , False, False
instead of line .Cells(1).PasteSpecial xlPastevalues, , False, False
Function re-written with said changes as below:
Function RangetoHTML(rng As Range)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy") & ".htm"
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).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
On Error GoTo 0
End With
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
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
Let me know if this solves your concern. :)