Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
useful html converters - http://ramblings.mcpher.com
Option Explicit
'v1.1 - 5116003
Private Function testTableToHtml()
Dim content As String, fn As String, _
sheetName As String, maxrows As Long, styles As String, _
outputType As String
' an example of how to use these
' you could make a form or dialog to set these up
' name of worksheet containing the data
sheetName = "sankey"
' max number of rows to take, 0 = all
maxrows = 0
' css styles to convert and copy from excel (takes much longer) - "" is no styles
styles = "color,background-color,font-size"
' can be 'google' or 'static'
outputType = "google"
'---------------------------
tableToHtml sheetName, , maxrows, styles, outputType
End Function
Public Function tableToHtml(sheetName As String, _
Optional Filename As String = vbNullString, _
Optional maxrows As Long = 0, _
Optional styles As String = vbNullString, _
Optional outputType As String = "google", _
Optional openIt As Boolean = True, _
Optional createIt As Boolean = True) As String
Dim fn As String, content As String
' get the html conversion
Select Case outputType
Case "google"
content = googleTableHtmlFromSheet(sheetName, maxrows, styles)
Case "static"
content = staticTableHtmlFromSheet(sheetName, maxrows, styles)
Case Else
MsgBox ("invalid outputtype")
Exit Function
End Select
' generate file name
If Filename = vbNullString Then
fn = outputType & sheetName & CStr(maxrows) & ".html"
Else
fn = Filename
End If
' optionally create the file and optionally open it
If openIt Or createIt Then
If (Not openNewHtml(fn, content)) Then
MsgBox ("couldnt create html file " & fn)
ElseIf openIt Then
If Not OpenUrl(fn) Then
MsgBox ("could not open " & fn & " using default browser")
End If
End If
End If
'return the content
tableToHtml = content
End Function
Public Function staticTableHtmlFromSheet(sheetName As String, _
Optional maxrows As Long, _
Optional stylesToCopy As String = vbNullString) As String
' turn a sheet into a static web page
Dim dc As cCell, theHeadings As String, theCode As String, _
theData As String, dr As cDataRow, _
v As Variant, p As Variant, t As cStringChunker, _
ds As cDataSet, styles As Variant, i As Long, _
c As String, theHeader As String, theBody As String, _
df As String, theTable As String
Set t = New cStringChunker
Set ds = New cDataSet
If Not stylesToCopy = vbNullString Then
styles = Split(stylesToCopy, ",")
End If
' create a dataset
With ds.populateData(wholeSheet(sheetName), , , , , , True, , maxrows)
' set up table headers
t.add (encloseTag("TR", , , _
encloseTag("TH", , , Split(.headingRow.headingList(), ","))))
theHeadings = encloseTag("THEAD", , , t.content)
t.clear
' the data content
c = "even"
For Each dr In .rows
If c = "even" Then
c = "odd"
Else
c = "even"
End If
t.add("<TR CLASS=").add(c).add (">")
For Each dc In dr.columns
t.add ("<TD")
p = dc.toString
' get any styling
If Not IsEmpty(styles) Then
t.add (" STYLE='")
For i = LBound(styles) To UBound(styles)
t.add cellCss(dc.where, CStr(styles(i)))
Next i
t.add ("'")
End If
If dc.parent.parent.columns(dc.column).googleType = "date" Then
df = dc.toString(, True)
Else
df = dc.toString
End If
t.add(">").add(df).add("</td>").add (vbCrLf)
Next dc
t.add ("</TR>")
Next dr
theData = encloseTag("TBODY", True, , t.content)
t.clear
theTable = encloseTag("TABLE", , , theHeadings & theData)
theHeader = encloseTag("HEAD", , , encloseTag("STYLE", , , tableStyle()))
theBody = encloseTag("BODY", , , scrollHack & theTable & "</div>")
' now we have the table, write it to an html file
staticTableHtmlFromSheet = "<!Doctype html>" & encloseTag("HTML", , , theHeader & theBody)
.tearDown
End With
End Function
Public Function googleTableHtmlFromSheet(sheetName As String, _
Optional maxrows As Long, _
Optional stylesToCopy As String = vbNullString) As String
' create some html for a google table
Dim dc As cCell, theHeadings As String, theCode As String, _
theData As String, dr As cDataRow, _
v As Variant, p As Variant, t As cStringChunker, _
ds As cDataSet, styles As Variant, i As Long, _
u As cStringChunker, s As String, df As String
Set u = New cStringChunker
Set t = New cStringChunker
Set ds = New cDataSet
If Not stylesToCopy = vbNullString Then
styles = Split(stylesToCopy, ",")
End If
' create a dataset
With ds.populateData(wholeSheet(sheetName), , , , , , True, , maxrows)
' set up table headers
t.add "//--column headers from sheet" & .where.Worksheet.name & vbCrLf
For Each dc In .headings
' need to do a quick check to ensure that dates are not just times
With .columns(dc.column)
df = .googleType
If df = "date" Then
If Year(.min) <= 1900 Then
df = "string"
End If
End If
End With
t.add googleColumnName(escapeify(dc.toString), _
df) & vbCrLf
Next dc
theHeadings = t.content
' just reuse it
t.clear
' now the data content
t.add "//--data content for " & .where.Worksheet.name & vbCrLf
t.add "//--table dimensions are " & _
.rows.count & " rows by " & .columns.count & " columns" & vbCrLf
t.add "data.addRows(" & .rows.count & ");" & vbCrLf
' minify addition of cells with a shortname version of the function
t.add "var m = function (a,b,c,d,e) {data.setCell (a,b,c,d,e) ;};" & vbCrLf
For Each dr In .rows
For Each dc In dr.columns
' get the value
p = "null"
If Not IsEmpty(dc.value) Then
Select Case .columns(dc.column).googleType
Case "string"
p = "'" & escapeify(dc.toString) & "'"
Case "date"
If (Year(dc.value) > 1900) Then
' its a date
p = "new Date(" & Year(dc.value) & "," & _
Month(dc.value) & "," & Day(dc.value) & "," & _
Hour(dc.value) & "," & Minute(dc.value) & "," _
& Second(dc.value) & ")"
Else
'its just a time
p = "'" & escapeify(dc.toString(, True)) & "'"
End If
Case "number"
p = dc.toString
Case "boolean"
If dc.value Then
p = "true"
Else
p = "false"
End If
Case Else
Debug.Assert False
End Select
End If
' get the style
u.clear
If Not IsEmpty(styles) Then
For i = LBound(styles) To UBound(styles)
u.add cellCss(dc.where, CStr(styles(i)))
Next i
s = ",null,{'style':'" & u.content & "'}"
End If
' combine them
t.add "m(" & dc.row - 1 & "," & _
dc.column - 1 & "," & p & s & ");" & vbCrLf
Next dc
Next dr
theData = t.content
' compile the whole thing
theCode = _
"<script type='text/javascript' src='https://www.google.com/jsapi'></script>" & vbCrLf & _
"<script type='text/javascript'>" & vbCrLf & _
"//--google table visualization content for " & .where.Worksheet.name & _
" created at " & Now() & " see ramblings.mcpher.com for how " & vbCrLf & _
"google.load('visualization', '1', {packages:['table']});" & vbCrLf & _
"google.setOnLoadCallback(drawTable);" & vbCrLf & _
"function drawTable() {" & vbCrLf & _
"var data = new google.visualization.DataTable();" & vbCrLf & _
theHeadings & vbCrLf & theData & vbCrLf & _
"var table = new google.visualization.Table(document.getElementById('table_div'));" & vbCrLf & _
"table.draw(data, {showRowNumber: false, allowHtml: true});}</script>" & vbCrLf
.tearDown
End With
googleTableHtmlFromSheet = _
encloseTag("html", , , _
encloseTag("head", , , theCode) & _
encloseTag("body", , , scrollHack & vbCrLf & "<div id='table_div'></div></div>") & vbCrLf)
End Function
Private Function googleColumnName(columnName As String, _
Optional columnType As String = "string") As String
googleColumnName = "data.addColumn('" & columnType & "' , '" & columnName & "');"
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.