useful html converters - http://ramblings.mcpher.com

usefulHtmlConverters.vba

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