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
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

Code:
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