Public Function SheetToHTML(sh As Worksheet)
Dim TempFile As String
Dim fso As Object
Dim ts As Object
Randomize
sh.Copy
TempFile = sh.Parent.Path & "\TmpHTML" & Int(Rnd() * 10) & ".htm"
ActiveWorkbook.SaveAs TempFile, xlHtml
ActiveWorkbook.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
SheetToHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Function
Function RangetoHTML(Rng As Range)
Dim wb As Workbook
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim i As Long
Dim Rng2 As Range
Dim DelCol1 As String
Dim DelCol2 As String
Randomize
TempFile = Rng.Parent.Parent.Path & "\TmpHTML" & Int(Rnd() * 10) & ".htm"
'Copy the sheet to a new workbook and copy the cells to avoid the
'255 character limit when copying sheets
Rng.Parent.Copy
Rng.Parent.Cells.Copy ActiveSheet.Cells
Set wb = ActiveWorkbook
Set Rng2 = wb.Sheets(1).Range(Rng.Address)
'Convert to values
Rng2.Copy
Rng2.PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Delete rows below
Rng2.Parent.Rows(Rng2.Rows(Rng2.Rows.Count).Row + 1 & ":65536").Delete
'Delete columns to right
DelCol2 = Chr(64 + Rng2.Parent.Columns(Rng2.Columns _
(Rng2.Columns.Count).Column + 1).Column)
Rng2.Parent.Columns(DelCol2 & ":IV").Delete
'Delete rows above
If Rng2.Rows(1).Row > 1 Then
Rng2.Parent.Rows("1:" & Rng2.Rows(1).Row - 1).Delete
End If
'Delete columns to left
If Rng2.Columns(1).Column > 1 Then
DelCol1 = Chr(64 + Rng2.Parent.Columns(Rng2.Columns(1).Column - 1).Column)
Rng2.Parent.Columns("A:" & DelCol1).Delete
End If
wb.SaveAs TempFile, xlHtml
wb.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Function | 
