1
\$\begingroup\$

TagBuilder class: uses a Builder Pattern to create a TagBuilder Tree that will output HTML to be written to a WebBrowser control.

My main objective is to simulate a DataGridView and my focus is on generating HTML Tables using this class.

Please let me know if there are any improvements that I can make to the class, such as:

  • Functionality that needs to be generated to handle certain Tags or Tag attributes
  • Specific situations that need to be addressed
  • Improved naming of variables
  • Copy(Destination) is copying and pasting the HTML output as text to a range. I would like to copy and paste it as HTML

Data and Demo Userform Image

Class level variables:

  • AttributeList: An ArrayList that stores the Tag's Attributes
  • BooleanAttributeList: An ArrayList that stores the Tag's Boolean Attributes
  • ClassList: An ArrayList that stores the Tag's HTML classes
  • InnerText: Text to be added between opening and closing HTML Tags
  • SelfClosing: Indicates if the Tag should have an opening and closing tag or a single self closing tag
  • StrBuilder: Used by the ToString method to build the output string
  • StyleDict: Holds the inline styles in Key/Value pairs
  • TagList: An ArrayList that stores child TagBuilders
  • TagName: Type of Tag (e.g. TR, TD, THEAD)

Class Methods:

  • AddAttributes: Uses a ParamArray KeyValuePairs() to add attributes to AttributeList
  • AddBooleanAttributes: Adds Boolean attributes to BooleanAttributeList
  • AddClasses: Adds classes to ClassList
  • AddStyles: Uses a ParamArray KeyValuePairs() to add Keys and Values to StyleDict
  • AppendStyles: Parses the style in the StyleDict
  • Class_Initialize: Initiates the class
  • Copy: Copies ToString to the clipboard
  • This: Returns a reference to Me, the class instance
  • ToString: Returns the HTML output

Class: TagBuilder

Option Explicit
Private Type TVariables
    AttributeList As Object
    BooleanAttributeList As Object
    ClassList As Object
    StyleDict As Object
    TagList As Object
End Type

Public InnerText As String
Public SelfClosing As Boolean
Public TagName As String
Private Vars As TVariables

Private Sub Class_Initialize()
    With Vars
        Set .AttributeList = CreateObject("System.Collections.ArrayList")
        Set .BooleanAttributeList = CreateObject("System.Collections.ArrayList")
        Set .ClassList = CreateObject("System.Collections.ArrayList")
        Set Vars.StyleDict = CreateObject("Scripting.Dictionary")
        Set Vars.TagList = CreateObject("System.Collections.ArrayList")
    End With
End Sub

Public Function Add(sTagName As String, Optional bSelfClosing As Boolean) As IETools.TagBuilder
    With New TagBuilder
        .SelfClosing = bSelfClosing
        .TagName = sTagName
        Set Add = .This
        Vars.TagList.Add .This
    End With
End Function

Public Function AddAttributes(ParamArray KeyValuePairs() As Variant) As IETools.TagBuilder
    Dim x As Long
    Dim key As String
    For x = 0 To UBound(KeyValuePairs) Step 2
        key = KeyValuePairs(x) & "=" & Chr(34) & KeyValuePairs(x + 1) & Chr(34)
        If Not Vars.AttributeList.Contains(key) Then Vars.AttributeList.Add key
    Next
    Set AddAttributes = This
End Function

Public Function AddBooleanAttributes(ParamArray Args() As Variant) As IETools.TagBuilder
    Dim v As Variant
    For Each v In Args()
        If Not Vars.BooleanAttributeList.Contains(v) Then Vars.BooleanAttributeList.Add v
    Next
    Set AddBooleanAttributes = This
End Function

Public Function AddClasses(ParamArray Args() As Variant) As IETools.TagBuilder
    Dim v As Variant
    For Each v In Args()
        If Not Vars.ClassList.Contains(v) Then Vars.ClassList.Add v
    Next
    Set AddClasses = This
End Function

Public Function AddStyles(ParamArray KeyValuePairs() As Variant) As IETools.TagBuilder
    Dim x As Long
    For x = 0 To UBound(KeyValuePairs) Step 2
        If Not Vars.StyleDict.Exists(KeyValuePairs(x + 1)) Then
            Vars.StyleDict.Add KeyValuePairs(x), KeyValuePairs(x + 1)
        Else
            Vars.StyleDict(KeyValuePairs(x)) = KeyValuePairs(x + 1)
        End If
    Next
    Set AddStyles = This
End Function

Private Sub AppendStyles(StrBuilder As Object)
    Dim key As Variant
    StrBuilder.Append_3 " style="
    StrBuilder.Append_3 Chr(34)
    For Each key In Vars.StyleDict
        StrBuilder.Append_3 key & ":" & Vars.StyleDict(key) & ";"
    Next
    StrBuilder.Append_3 Chr(34)
End Sub

Public Sub Copy(Optional Destination As Object)
    Dim clip As Object
    Set clip = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    clip.Clear
    clip.SetText Me.ToString
    clip.PutInClipboard

    If Not Destination Is Nothing Then
        On Error Resume Next
        Destination.PasteSpecial
        On Error GoTo 0
    End If
End Sub

Function This() As IETools.TagBuilder
    Set This = Me
End Function

Public Function ToString() As String
    Dim Attribute1 As Variant, tg As IETools.TagBuilder, StrBuilder As Object
    Set StrBuilder = CreateObject("System.Text.StringBuilder")

    StrBuilder.Append_3 "<" & TagName

    If Vars.ClassList.Count > 0 Then StrBuilder.Append_3 " class=" & Chr(34) & Join(Vars.ClassList.ToArray, " ") & Chr(34)
    If Vars.StyleDict.Count > 0 Then AppendStyles StrBuilder
    If Vars.AttributeList.Count > 0 Then StrBuilder.Append_3 " " & Join(Vars.AttributeList.ToArray, " ")
    If Vars.BooleanAttributeList.Count > 0 Then StrBuilder.Append_3 " " & Join(Vars.BooleanAttributeList.ToArray, " ")

    If SelfClosing Then
        StrBuilder.Append_3 "/>"
    Else
        StrBuilder.Append_3 ">"
        StrBuilder.Append_3 InnerText
        For Each tg In Vars.TagList
            StrBuilder.Append_3 tg.ToString
        Next
        StrBuilder.Append_3 "</" & TagName & ">"
    End If
    ToString = StrBuilder.ToString
End Function

getHexColor is used to convert Excel colors into hex.

Inside a Public Module

' https://stackoverflow.com/questions/6003324/how-do-i-get-the-corresponding-hex-value-of-an-rgb-color-in-excel-vba
Public Function getHexColor(strColour As Variant, Optional bFontColor As Boolean) As String
    Dim hexColour As String
    Dim nColour As Long
    Dim nR As Long, nB As Long, nG As Long
    If IsNull(strColour) Then
        getHexColor = "#000"
        Exit Function
    End If

    If Len(strColour) = 0 Then
        getHexColor = "#000"
        Exit Function
    End If

    nColour = Val(strColour)                          ' convert string to decimal number
    hexColour = Hex(nColour)                          ' convert decimal number to hex string
    While Len(hexColour) < 6                          ' pad on left to 6 hex digits
        hexColour = "0" & hexColour
    Wend

    nB = CLng("&H" & Mid(hexColour, 1, 2))
    nG = CLng("&H" & Mid(hexColour, 3, 2))
    nR = CLng("&H" & Mid(hexColour, 5, 2))

    getHexColor = "#" & Hex(RGB(nB, nG, nR))
End Function

To test/demonstrate the pattern I created an Userform with a WebBrowser on it.

Demo Userform Code

Private Sub UserForm_Initialize()
    Dim x As Long
    Dim cell As Range, source As Range
    Dim background_color As String, font_color As String
    Dim TableTag As TagBuilder
    Set TableTag = New TagBuilder
    TableTag.TagName = "TABLE"
    TableTag.AddAttributes "ID", "Table1"

    With ThisWorkbook.Worksheets("Mock Data")
        Set cell = .Range("A1")
        Set source = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))

        With TableTag.Add("THEAD")
            background_color = getHexColor(cell.Interior.Color)
            font_color = getHexColor(cell.Font.Color)
            With .Add("TR")
                .AddStyles "background-color", background_color, "color", font_color
                .Add("TH").InnerText = cell
                .Add("TH").InnerText = cell.Offset(0, 1)
                .Add("TH").InnerText = cell.Offset(0, 2)
                .Add("TH").InnerText = cell.Offset(0, 3)
                .Add("TH").InnerText = cell.Offset(0, 4)
                .Add("TH").InnerText = cell.Offset(0, 5)
                .Add("TH").InnerText = cell.Offset(0, 6)
            End With
        End With

        With TableTag.Add("TBODY")
            For Each cell In source
                background_color = getHexColor(cell.Interior.Color)
                font_color = getHexColor(cell.Font.Color)
                With .Add("TR")
                    .AddStyles "background-color", background_color, "color", font_color
                    .Add("TD").InnerText = cell
                    .Add("TD").InnerText = cell.Offset(0, 1)
                    .Add("TD").InnerText = cell.Offset(0, 2)
                    .Add("TD").InnerText = cell.Offset(0, 3)
                    .Add("TD").InnerText = cell.Offset(0, 4)
                    .Add("TD").InnerText = cell.Offset(0, 5)
                    With .Add("TD")
                        With .Add("INPUT")
                            .AddAttributes("type", "checkbox").SelfClosing = True
                            If CBool(cell.Offset(0, 6)) Then .AddBooleanAttributes "checked"
                        End With
                    End With
                End With
            Next
        End With
    End With

    With WebBrowser1
        .Navigate2 "About:Blank"
        .Document.Write TableTag.ToString
        TableTag.Copy
    End With
End Sub

Output:

This is the HTML that the TagBuilder demo outputs after I formatted it using freeformatter.com

<TABLE ID="Table1">
   <THEAD>
      <TR style="background-color:#7030A0;color:#FFFFFF;">
         <TH>id</TH>
         <TH>first_name</TH>
         <TH>last_name</TH>
         <TH>email</TH>
         <TH>gender</TH>
         <TH>ip_address</TH>
         <TH>verified</TH>
      </TR>
   </THEAD>
   <TBODY>
      <TR style="background-color:#B2A1C7;color:#0;">
         <TD>1</TD>
         <TD>Deerdre</TD>
         <TD>Dunican</TD>
         <TD>ddunican0@tamu.edu</TD>
         <TD>Female</TD>
         <TD>143.240.205.121</TD>
         <TD><INPUT type="checkbox" checked/></TD>
      </TR>
      <TR style="background-color:#E5E0EC;color:#0;">
         <TD>2</TD>
         <TD>Else</TD>
         <TD>Newcome</TD>
         <TD>enewcome1@mediafire.com</TD>
         <TD>Female</TD>
         <TD>221.110.233.114</TD>
         <TD><INPUT type="checkbox" checked/></TD>
      </TR>
      <TR style="background-color:#B2A1C7;color:#0;">
         <TD>3</TD>
         <TD>Ricki</TD>
         <TD>Binns</TD>
         <TD>rbinns2@pen.io</TD>
         <TD>Female</TD>
         <TD>255.68.156.128</TD>
         <TD><INPUT type="checkbox"/></TD>
      </TR>
      <TR style="background-color:#E5E0EC;color:#0;">
         <TD>4</TD>
         <TD>Lorette</TD>
         <TD>Mancell</TD>
         <TD>lmancell3@dell.com</TD>
         <TD>Female</TD>
         <TD>27.148.40.115</TD>
         <TD><INPUT type="checkbox" checked/></TD>
      </TR>
      <TR style="background-color:#B2A1C7;color:#0;">
         <TD>5</TD>
         <TD>Marylin</TD>
         <TD>MacCallion</TD>
         <TD>mmaccallion4@omniture.com</TD>
         <TD>Female</TD>
         <TD>173.46.218.126</TD>
         <TD><INPUT type="checkbox"/></TD>
      </TR>
      <TR style="background-color:#E5E0EC;color:#0;">
         <TD>6</TD>
         <TD>Alena</TD>
         <TD>Hayfield</TD>
         <TD>ahayfield5@webs.com</TD>
         <TD>Female</TD>
         <TD>225.232.89.24</TD>
         <TD><INPUT type="checkbox"/></TD>
      </TR>
      <TR style="background-color:#B2A1C7;color:#0;">
         <TD>7</TD>
         <TD>Blythe</TD>
         <TD>Kelsow</TD>
         <TD>bkelsow6@baidu.com</TD>
         <TD>Female</TD>
         <TD>148.2.125.197</TD>
         <TD><INPUT type="checkbox" checked/></TD>
      </TR>
      <TR style="background-color:#E5E0EC;color:#0;">
         <TD>8</TD>
         <TD>Nevsa</TD>
         <TD>Dimnage</TD>
         <TD>ndimnage7@xing.com</TD>
         <TD>Female</TD>
         <TD>133.73.46.255</TD>
         <TD><INPUT type="checkbox" checked/></TD>
      </TR>
      <TR style="background-color:#B2A1C7;color:#0;">
         <TD>9</TD>
         <TD>Min</TD>
         <TD>Wakeling</TD>
         <TD>mwakeling8@state.gov</TD>
         <TD>Female</TD>
         <TD>113.95.233.177</TD>
         <TD><INPUT type="checkbox" checked/></TD>
      </TR>
   </TBODY>
</TABLE>

Data generated by mockaroo.com

\$\endgroup\$
  • 1
    \$\begingroup\$ That's quite awesome! I hope you get good reviews! I spotted what appears to be a redundant With CreateObject("System.Text.StringBuilder") block while quick-scanning the code, other than that looks pretty neat IMO.. At least at first glance =) \$\endgroup\$ – Mathieu Guindon Oct 25 '17 at 23:12
  • \$\begingroup\$ @Mat'sMug that's awesome! Your opinion means a lot. I removed the unused With statement. I missed it when I copied the code from another class that I had. \$\endgroup\$ – user109261 Oct 26 '17 at 1:05
  • \$\begingroup\$ @Mat'sMug FYI: I updated my code moving several public objects into a private type TVariables and declaring Private Vars As TVariables at the Class level. I based this off of the vba collection wrapper you posted a while back. \$\endgroup\$ – user109261 Oct 26 '17 at 20:35
  • \$\begingroup\$ What's IETools? \$\endgroup\$ – Raystafarian Mar 16 '18 at 4:25
  • \$\begingroup\$ I renamed the VBAProject to IETools \$\endgroup\$ – user109261 Mar 16 '18 at 4:46

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy