Generate An HTML Table String From An Access Table

This is a continuation of my earlier post:

Generate an HTML Table String from a Query's Recordset

Below was my solution to export a query, or table, as a HTML Table string which then can be used in e-mails, to generate standalone HTML files, ...

That I have created because of my recent video on the subject:

The difference here is that instead of exporting a query, the following code will export a table.

'---------------------------------------------------------------------------------------
' Procedure : GenHTMLTable_Table
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Generate an HTML Table string from a Table's Recordset
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sTable        : Name of the table to use to create the HTML Table string from
' bInclHeader   : True/False whether to include a header row with the field names
'
' Usage:
' ~~~~~~
' sMsg = GenHTMLTable_Table("YourTableName") 'With a Header Row
' sMsg = GenHTMLTable_Table("YourTableName", FALSE) 'No Header Row
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2017-02-14              Initial Release
' 2         2018-09-20              Updated Copyright
' 3         2021-12-17              Implemented thead and tbody for proper table HTML
' 4         2023-05-18              Fix location of tbody tags
' 5         2023-05-19              Renamed function
'---------------------------------------------------------------------------------------
Function GenHTMLTable_Table(sTable As String, Optional bInclHeader As Boolean = True) As String
    On Error GoTo Error_Handler
    Dim db                    As DAO.Database
    Dim rs                    As DAO.Recordset
    Dim fld                   As DAO.Field
    Dim sHTML                 As String

    Set db = CurrentDb
    Set rs = db.OpenRecordset(sTable, dbOpenSnapshot)
    With rs
        sHTML = "<table>" & vbCrLf
        'sHTML = "<table border='1' style='border-collapse:collapse;'>" & vbCrLf
        If bInclHeader = True Then
            'Build the header row if requested
            sHTML = sHTML & vbTab & "<thead>" & vbCrLf
            sHTML = sHTML & vbTab & vbTab & "<tr>" & vbCrLf
            For Each fld In rs.Fields
                sHTML = sHTML & vbTab & vbTab & vbTab & "<th>" & _
                        fld.Name & "</th>" & vbCrLf
            Next
            sHTML = sHTML & vbTab & vbTab & "</tr>" & vbCrLf
            sHTML = sHTML & vbTab & "</thead>" & vbCrLf
        End If
        If .RecordCount <> 0 Then
            sHTML = sHTML & vbTab & "<tbody>" & vbCrLf
            Do While Not .EOF
                'Build a row for each record in the recordset
                sHTML = sHTML & vbTab & vbTab & "<tr>" & vbCrLf
                For Each fld In rs.Fields
                    sHTML = sHTML & vbTab & vbTab & vbTab & "<td>" & _
                            Nz(fld.Value, "") & "</td>" & vbCrLf
                Next
                sHTML = sHTML & vbTab & vbTab & "</tr>" & vbCrLf
                .MoveNext
            Loop
            sHTML = sHTML & vbTab & "</tbody>" & vbCrLf
        End If
        sHTML = sHTML & "</table>"
    End With

    GenHTMLTable_Table = sHTML

Error_Handler_Exit:
    On Error Resume Next
    If Not fld Is Nothing Then Set fld = Nothing
    If Not rs Is Nothing Then
        rs.Close
        Set rs = Nothing
    End If
    If Not db Is Nothing Then Set db = Nothing
    Exit Function

Error_Handler:
  Debug.Print fld.Name
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: GenHTMLTable_Table" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Function

7 responses on “Generate An HTML Table String From An Access Table”

David Marten May 20, 2023 at 10:13 am

I have an old function that leverages the GetString method of an ADODB recordset to do the same (No reference required!)

Function HTMLTbl(strSQL As String, Optional blHeaders = True) As String
On Error GoTo Err_HTMLTbl

  Dim html                As String, _
      header              As String, _
      i                   As Integer
  
  Const SP2               As String = "  "
  Const SP4               As String = SP2 & SP2
  Const SP6               As String = SP2 & SP4
  Const FIELD_SEPARATOR   As String = "</td>" & vbNewLine & SP6 & "<td>"
  Const ROW_START         As String = SP4 & "<tr>" & vbNewLine & SP6 & "<td>"
  Const ROW_END           As String = "</td>" & vbNewLine & SP4
  Const RECORD_SEPARATOR  As String = ROW_END & "</tr>" & vbNewLine & ROW_START
  
  With CurrentProject.Connection.Execute(strSQL)
    If blHeaders Then
      For i = 0 To .Fields.Count - 1
        header = header & SP6 & "<th>" & .Fields(i).Name & "</th>" & vbNewLine
      Next i
      header = SP2 & "<thead>" & vbNewLine & SP4 & "<tr>" & vbNewLine & header & SP4 & "</tr>" & vbNewLine & SP2 & "</thead>" & vbNewLine
    End If
    If Not .EOF Then
      html = .GetString(, , FIELD_SEPARATOR, RECORD_SEPARATOR)
      html = SP2 & "<tbody>" & vbNewLine & _
             ROW_START & _
             Left(html, Len(html) - Len(ROW_START)) & SP2 & _
             "</tbody>" & vbNewLine
    End If
    .Close
  End With

Exit_HTMLTbl:
  HTMLTbl = "<table>" & vbNewLine & header & html & "</table>"
  Exit Function

Err_HTMLTbl:
  Select Case Err.NUMBER
  Case Else
    MsgBox "Error No.: " & Err.NUMBER & vbNewLine & vbNewLine & _
           "Description: " & Err.Description & vbNewLine & vbNewLine & _
           "Function: HTMLTbl" & vbNewLine & _
           IIf(Erl, "Line No: " & Erl & vbNewLine, "") & _
           "Module: " & Application.VBE.ActiveCodePane.CodeModule.Name, , _
           "Error: " & Err.NUMBER
  End Select
  Resume Exit_HTMLTbl
  
End Function

David Marten May 20, 2023 at 10:17 am

Sorry, Daniel, it loses the formatting when posting!

Daniel Pineault Post authorMay 20, 2023 at 11:44 am

I’ve hopefully fixed the formatting issue.
1. David Marten June 11, 2023 at 3:51 pm
  
  Awesome! Looks fine now – hopefully someone may find it useful.
  
  Thanks, Daniel.

Michael Flanagan May 27, 2023 at 4:08 am

Great function, but does not seem to generate entire table in the Immediate Window if the table has more than 30 or so records. Is this a limitation of the Immediate Window?

Daniel Pineault Post authorMay 27, 2023 at 5:32 am

There are no limitation, but yes, the content can easily exceed the limits of the Immediate Window and thus cut off the content.

For testing purposes, instead of outputting to the Immediate Window, try outputting to a text file (or .html) by using something like https://www.devhut.net/vba-export-to-text-file/.

Michael Flanagan May 27, 2023 at 9:21 am

Thanks – it works when outputting to a text file. Very helpful.