Issues with copying hyperlinks in cells (RangetoHTML)

[archoct]

Hi,


I have a sheet with a table. The cells of the table has a formula to create hyperlink for them. this formula operates on the content from another 2 sheets.


I am copying the resultant table and trying to retain the hyperlink, but as i found out the RangetoHTML function does not retain hyperlink and has only the format retained. found couple of hacks in the google to add code in RangetoHTML to make it copy/recreate the link. but the link is itself not hardcoded and its dynamically created based on worksheet content.


this is the formula in the table in each cell


HYPERLINK((Sheet4!$E$29&"\"&$C22&"_"&'Sheet5'!CT$1&"_warnings.txt"), 'Sheet5'!CT18), "")


this is code i am using which does not copy the hyperlink

Please suggest where i can modify so that the hyperlink can be added in the the result

Sub CreateMail()




    Dim objOutlook As Object
    Dim objMail As Object
    Dim rngTo As Range
    Dim rngSubject As Range
    Dim rngBody As Range
    Dim rngAttach As Range




    Dim rngdatatable As Range
    Dim rngmaintable As Range
    Dim rngmain1table As Range
    Dim rngunitSummarytable As Range
    Dim rngb4unitSummarytable As Range
    Dim rngunitSummarytablemain As Range
    Dim rngchannel As Range
    
    Dim strTextWar1 As String
    Dim strTextWar2 As String
    Dim strbodystart As String
    Dim strbodyend As String
    Dim strMainTab As String
    Dim strMainTabx As String
    Dim strUnitTab As String
    Dim strUnitTabx As String
    Dim i As Integer
    Dim rangeArray() As Range
    Dim rangeArrayx() As Range
    




     strbodystart = ""
     strbodyend = ""








    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    i = 1
    ReDim rangeArray(1 To 5)
    ReDim rangeArrayx(1 To 50)








With Worksheets("Test Summary").Range("G8:G19")
    Set c = .Find("XXXX")
    
    If Not c Is Nothing Then
   
        firstAddress = c.Address
        'Set rngmain1table = Worksheets("Test Summary").Range("A1")
        Do
            
            currentAddress = c.Address
            columnNo = InStr(currentAddress, "G")
            columnNumber = Mid(currentAddress, columnNo + 2)
            Set rangeArray(i) = Worksheets("Test Summary").Range("A" & columnNumber & ":Q" & columnNumber)
            Set c = .FindNext(c)
            i = i + 1
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With




' add a loop to develop concat string wth the RangeToHTML data




x = 1
strMainTab = ""
strMainTabx = ""
While x < i




strMainTab = RangetoHTML(rangeArray(x))
'MsgBox strMainTab
strMainTabx = strMainTab & strMainTabx
x = x + 1




Wend
' code for unit summary table
i = 1
With Worksheets("Unit Summary").Range("I6:I50")
    Set c = .Find(What:="XXXX", LookIn:=xlValues)
    
    If Not c Is Nothing Then
   
        firstAddress = c.Address
        
        Do
            currentAddress = c.Address
            columnNo = InStr(currentAddress, "I")
            columnNumber = Mid(currentAddress, columnNo + 2)
            Set rangeArrayx(i) = Worksheets("Unit Summary").Range("B" & columnNumber & ":IL" & columnNumber).SpecialCells(xlCellTypeVisible)
             Set c = .FindNext(c)
            i = i + 1
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With




' add a loop to develop concat string wth the RangeToHTML data




x = 1
strUnitTab = ""
strUnitTabx = ""
While x < i




strUnitTab = RangetoHTML(rangeArrayx(x))
'MsgBox strMainTab
strUnitTabx = strUnitTab & strUnitTabx
x = x + 1




Wend




'MsgBox strMainTab




    Set rngTo = Worksheets("Test Summary").Range("H1")
    Set rngSubject = Worksheets("Test Summary").Range("G1")
    Set rngdatatable = Worksheets("Test Summary").Range("B2:G4")
    Set rngmaintable = Worksheets("Test Summary").Range("A6:Q7")
    Set rngchannel = Worksheets("Test Summary").Range("F11")
    Set rngunitSummarytablemain = Worksheets("Unit Summary").Range("B3:IL5").SpecialCells(xlCellTypeVisible)
        
    strTextWar1 = GetFileContent("C:\Warnings1.html")
    strTextWar2 = GetFileContent("C:\Warnings2.html")
    
    With objMail
        .To = rngTo.Value
        .Subject = rngSubject.Value
                
 .HTMLBody = strbodystart & RangetoHTML(rngdatatable) & RangetoHTML(rngmaintable) & strMainTabx & rngchannel & strTextWar1 & rngchannel & strTextWar2 & RangetoHTML(rngunitSummarytablemain) & strUnitTabx & strbodyend




              .Display
    End With




    Set objOutlook = Nothing
    Set objMail = Nothing
    Set rngTo = Nothing
    Set rngSubject = Nothing
    Set rngBody = Nothing
    Set rngAttach = Nothing




End Sub












Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
   
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"




    'Copy the range and create a new workbook to paste the data in
    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
        .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=")
    RangetoHTML = Replace(RangetoHTML, "", "")
    '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
 




Function GetFileContent(Name As String) As String
    Dim intUnit As Integer
     
    On Error GoTo ErrGetFileContent
    intUnit = FreeFile
    Open Name For Input As intUnit
    GetFileContent = Input(LOF(intUnit), intUnit)
ErrGetFileContent:
    Close intUnit
    Exit Function
End Function

 

[John_w]

See http://www.mrexcel.com/forum/excel-...er-rangetohtml-paste-outlook.html#post2884726

However that code requires the hyperlinks to be hyperlink objects (in the Sheet.Hyperlinks collection), rather than =HYPERLINK function formulas. You therefore need to convert formulas which use =HYPERLINK functions to hyperlink objects. Here is one way, which parses the =HYPERLINK function in A1 as an example and creates an equivalent hyperlink object in A2.

Sub Test()

    Dim p1 As Long, p2 As Long
    
    With Sheets("Sheet1").Range("A1")
        If InStr(UCase(.Formula), "=HYPERLINK(") > 0 Then
            p1 = InStr(.Formula, "(")
            p2 = InStr(p1, .Formula, ",")
            Debug.Print Evaluate(Mid(.Formula, p1 + 1, p2 - p1 - 1))
            .Offset(1, 0).Parent.Hyperlinks.Add Anchor:=.Offset(1, 0), Address:=Evaluate(Mid(.Formula, p1 + 1, p2 - p1 - 1)), TextToDisplay:=.Value
        End If
    End With
    
End Sub

Combining the 2 bits of code with RangeToHTML should give you a working solution.