XenoEngineer: /* Test Form */

2026-03-01T04:19:52Z

Test Form

← Older revision		Revision as of 04:19, 1 March 2026
Line 200:		Line 200:
	==Test Form==		==Test Form==
	<pre style="margin-left:3em; font:normal 14px terminal;">''		<pre style="margin-left:3em; font:normal 14px terminal;">''
	'' ~~clsJSONNOde~~		'' frmJSONNOdeTest
	'' Copyright 2026 Don 'XenoEngineer' Mitchell		'' Copyright 2026 Don 'XenoEngineer' Mitchell
	''		''

XenoEngineer: Created page with "Category:VB6 ==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 typ..."

2026-03-01T04:19:14Z

Created page with "Category:VB6 ==VB6 Class Code== <pre style="margin-left:3em; font:normal 14px terminal;"> '' 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 typ..."

New page

[[Category:VB6]]

==VB6 Class Code==
<pre style="margin-left:3em; font:normal 14px terminal;">
'' 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

</pre>

==Test Form==
<pre style="margin-left:3em; font:normal 14px terminal;">''
'' clsJSONNOde
'' 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

</pre>

VB6 clsJSONNode - Revision history

XenoEngineer: /* Test Form */