VB6 clsJSONNode

VB6 Class Code

''  Class clsJSONNode

Option Explicit

Public Enum enumNodeType
    enuObjectType
    enuArrayType
    enuValueType
End Enum


Private Type udtJSONNode
    nodeType    As enumNodeType
    Object      As Scripting.Dictionary
    Array       As Collection
    value       As Variant
End Type

Private m As udtJSONNode


Private Sub Class_Initialize()
    ''  Default to object type as associative array (Dictionary).
    m.nodeType = enuObjectType
    
    Set m.Object = New Scripting.Dictionary
End Sub

Private Sub Class_Terminate()
    Set m.Object = Nothing
End Sub

Public Function AddObject(key As String) As clsJSONNode
    If m.nodeType <> enuObjectType Then Err.Raise 5, , "Not an object"
    Dim child As New clsJSONNode
    
    child.InitObject
    
    m.Object.Add key, child
    Set AddObject = child
End Function

Public Function AddArray(key As String) As clsJSONNode
    If m.nodeType <> enuObjectType Then Err.Raise 5, , "Not an object"
    
    Dim child As New clsJSONNode
    
    child.InitArray
    
    m.Object.Add key, child
    Set AddArray = child
    
End Function

Public Function AddObjectValue(key As String, v As Variant) As clsJSONNode
    If m.nodeType <> enuObjectType Then Err.Raise 5, , "Not an object"
    Dim child As New clsJSONNode
    child.SetValue v
    m.Object.Add key, child
    Set AddObjectValue = child
End Function

Public Function AddArrayValue(v As Variant) As clsJSONNode
    Dim child As New clsJSONNode
    
    If m.nodeType <> enuArrayType Then Err.Raise 5, , "Not an array"
    
    child.SetValue v
    m.Array.Add child
    Set AddArrayValue = child
End Function





Public Sub InitObject()
    m.nodeType = enuObjectType
    Set m.Object = New Scripting.Dictionary
    
    Set m.Array = Nothing
    m.value = Empty
End Sub

Public Sub InitArray()
    m.nodeType = enuArrayType
    Set m.Array = New Collection
    Set m.Object = Nothing
    m.value = Empty
End Sub

Public Sub SetValue(v As Variant)
    m.nodeType = enuValueType
    m.value = v
    Set m.Object = Nothing
    Set m.Array = Nothing
End Sub

Public Property Let nodeType(value As enumNodeType)
    m.nodeType = value
End Property

Public Property Get nodeType() As enumNodeType
    nodeType = m.nodeType
End Property


Public Function ToJSON(Indent As Integer) As String
    Dim json As String
    Dim i As Integer
    Dim spacer As String

    ' Create an indentation string
    For i = 1 To Indent
        spacer = spacer & "  "
    Next i

    Select Case m.nodeType
        Case enuValueType
            ToJSON = ValueToString(m.value, Indent)
        Case enuObjectType
            ToJSON = ObjectToString(spacer, Indent)
        Case enuArrayType
            ToJSON = ArrayToString(spacer, Indent)
        Case Else
            Err.Raise 5, , "Invalid node type"
    End Select
End Function

Private Function ValueToString(v As Variant, Indent As Integer) As String
    If VarType(v) = vbString Then
        ValueToString = """" & Replace(v, """", "\""") & """"
    ElseIf VarType(v) = vbBoolean Then
        ValueToString = IIf(v, "true", "false")
    ElseIf VarType(v) = vbInteger Or VarType(v) = vbLong Or VarType(v) = vbSingle Or VarType(v) = vbDouble Then
        ValueToString = CStr(v)
    ElseIf IsNull(v) Then
        ValueToString = "null"
    Else
        Err.Raise 5, , "Unsupported value type"
    End If
End Function

Private Function ObjectToString(spacer As String, Indent As Integer) As String
    Dim json As String
    Dim key As Variant

    json = "{"

    ' Check if the object is not empty
    If m.Object.Count > 0 Then
        json = json & vbCrLf & spacer & "  "
        Dim first As Boolean
        first = True
        For Each key In m.Object.Keys
            If first = False Then
                json = json & "," & vbCrLf & spacer & "  "
            Else
                first = False
            End If
            json = json & """" & key & """" & ": " & m.Object(key).ToJSON(Indent + 1)
        Next key
        json = json & vbCrLf & spacer & "}"
    Else
        json = json & "}"
    End If

    ObjectToString = json
End Function

Private Function ArrayToString(spacer As String, Indent As Integer) As String
    Dim json As String
    Dim i As Long

    json = "["

    ' Check if the array is not empty
    If m.Array.Count > 0 Then
        json = json & vbCrLf & spacer & "  "
        For i = 1 To m.Array.Count
            If i > 1 Then json = json & "," & vbCrLf & spacer & "  "
            json = json & m.Array(i).ToJSON(Indent + 1)
        Next i
        json = json & vbCrLf & spacer & "]"
    Else
        json = json & "]"
    End If

    ArrayToString = json
End Function

Test Form

''  
''  frmJSONNOdeTest
''  Copyright 2026 Don 'XenoEngineer' Mitchell
''

Option Explicit

Private Type udtForm
    root        As clsJSONNode
    objectFile  As String
End Type

Private m As udtForm

                    
Private Sub cmdAddRoot_Click()
    Set m.root = New clsJSONNode
    
    m.root.InitObject
    
    With m.root.AddObject("user")
        .AddObjectValue "name", txtName.Text
        .AddObjectValue "age", txtAge.Text
        With .AddArray("roles")
            .AddArrayValue txtRole1.Text
            .AddArrayValue txtRole2.Text
        End With
    End With
    
    txtJSON.Text = m.root.ToJSON(1)
    Debug.Print m.root.ToJSON(Indent:=2)
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case vbKeyEscape
            Unload Me
        Case Else
    End Select
End Sub

Private Sub Form_Load()
    Me.KeyPreview = True
End Sub

Private Sub Form_Terminate()
    Set m.root = Nothing
End Sub