Retain hyperlinks in table column after rangetohtml paste for Outlook Email Body table

[aussiechess]

Hi everyone, I'm trying to retain hyperlinks in an email generated using VBA, using the RangetoHTML function from Rondebruin's website. The hyperlinks are all in a table column of a table that's shown in the email body.

Using the original Rondebruin code, I am able to paste all the correct values shown in the original table but the column with hyperlinks is only showing the values and not activated hyperlinks (cannot be clicked on).

I've also tried the solutions recommended in this thread but they aren't working for me: Retain hyperlinks after rangetohtml paste Outlook?.

I've also tried using .Cells(1).PasteSpecial xlPasteAll, , False, False but this messes up the AutoFilter component and does not send the correct rows to the correct recipient.

Can someone please help me with an amendment to the below code to get the hyperlinks activated within the table? Thank you!

Sub SendMultiplevFINAL()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FilterRange As Range
    Dim FieldNum As Integer
    Dim mailAddress As String
    Dim EmailStart As String
    Dim EmailEnd As String

    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
        
    
    'Set filter sheet, you can also use Sheets("MySheet")
    Set Ash = Sheets("Email Output")

    'Set filter range and filter column (Column with names)
    Set FilterRange = Ash.Range("A1:J" & Ash.Rows.Count)
    FieldNum = 10    'Filter column = J because the filter range start in J

    'Add a worksheet for the unique list and copy the unique list in A1
    Set Cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:="", Unique:=True

    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount

            'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=FieldNum, _
                                   Criteria1:=Cws.Cells(Rnum, 1).Value

            'Look for the mail address in the List worksheet
            mailAddress = ""
            On Error Resume Next
            mailAddress = Application.WorksheetFunction. _
                          VLookup(Cws.Cells(Rnum, 1).Value, _
                                Worksheets("List").Range("A1:B" & _
                                Worksheets("List").Rows.Count), 2, False)
            On Error GoTo 0
            
            'Look for the greeting name in the List worksheet
            GreetingName = ""
            On Error Resume Next
            GreetingName = Application.WorksheetFunction. _
                          VLookup(Cws.Cells(Rnum, 1).Value, _
                                Worksheets("List").Range("A1:C" & _
                                Worksheets("List").Rows.Count), 3, False)
            On Error GoTo 0
            
            EmailStart = "<p>" & "Hi " & GreetingName & _
            
            If mailAddress <> "" Then
            
            With Ash.AutoFilter.Range
                On Error Resume Next
                With .Resize(, .Columns.Count - 1)
                    Set rng = .SpecialCells(xlCellTypeVisible)
                End With

                On Error GoTo 0
            End With
            
                Set OutMail = OutApp.CreateItem(0)

                On Error Resume Next
                With OutMail
                    .To = mailAddress
                    .CC = Sheets("Email Details").Range("CC").Value
                    .Subject = Sheets("Email Details").Range("Subject").Value
                    .HTMLBody = EmailStart & _
                        "<p align='left'><table><tbody><tr><td>" & RangetoHTML(rng) & "</td></tr></tbody></table></p><br>"
  
                    .Display  'Or use Send
                End With
                On Error GoTo 0

                Set OutMail = Nothing
            End If
            

            'Close AutoFilter
            Ash.AutoFilterMode = False

        Next Rnum
    End If

cleanup:
    Set OutApp = Nothing
    Application.DisplayAlerts = False
    Cws.Delete
    Application.DisplayAlerts = True

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub


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 workbook to receive the data.
    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).PasteSpecial xlPasteFormulas, , False, False
        .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 an .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 the RangetoHTML subroutine.
    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.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[aussiechess]

Hi all, just boosting this post. Still haven't found a solution to activate the hyperlinks in the table. Especially for the solution posted in the previous thread [For Each Hlink In rng.Hyperlinks], I was wondering if I somehow need to use a relative range and if so - how to code and activate this for the specific table format shown in the attached image?