cJSONScript.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cJSONScript"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Dim dictVars As New Dictionary
Dim plNestCount As Long


Public Function Eval(sJSON As String) As String
   Dim SB As New cStringBuilder
   Dim o As Object
   Dim c As Object
   Dim i As Long
   
   Set o = JSON.parse(sJSON)
   If (JSON.GetParserErrors = "") And Not (o Is Nothing) Then
      For i = 1 To o.Count
         Select Case VarType(o.Item(i))
         Case vbNull
            SB.Append "null"
         Case vbDate
            SB.Append CStr(o.Item(i))
         Case vbString
            SB.Append CStr(o.Item(i))
         Case Else
            Set c = o.Item(i)
            SB.Append ExecCommand(c)
         End Select
      Next
   Else
      MsgBox JSON.GetParserErrors, vbExclamation, "Parser Error"
   End If
   Eval = SB.toString
End Function

Public Function ExecCommand(ByRef obj As Variant) As String
   Dim SB As New cStringBuilder
   
   If plNestCount > 40 Then
      ExecCommand = "ERROR: Nesting level exceeded."
   Else
      plNestCount = plNestCount + 1
      
      Select Case VarType(obj)
         Case vbNull
            SB.Append "null"
         Case vbDate
            SB.Append CStr(obj)
         Case vbString
            SB.Append CStr(obj)
         Case vbObject
            
            Dim i As Long
            Dim j As Long
            Dim this As Object
            Dim key
            Dim paramKeys
            
            If TypeName(obj) = "Dictionary" Then
               Dim sOut As String
               Dim sRet As String
   
               Dim keys
               keys = obj.keys
               For i = 0 To obj.Count - 1
                  sRet = ""
             
                  key = keys(i)
                  If VarType(obj.Item(key)) = vbString Then
                     sRet = obj.Item(key)
                  Else
                     Set this = obj.Item(key)
                  End If
                  
                  ' command implementation
                  Select Case LCase(key)
                  Case "alert":
                     MsgBox ExecCommand(this.Item("message")), vbInformation, ExecCommand(this.Item("title"))
                     
                  Case "input":
                     SB.Append InputBox(ExecCommand(this.Item("prompt")), ExecCommand(this.Item("title")), ExecCommand(this.Item("default")))
                     
                  Case "switch"
                     sOut = ExecCommand(this.Item("default"))
                     sRet = LCase(ExecCommand(this.Item("case")))
                     For j = 0 To this.Item("items").Count - 1
                        If LCase(this.Item("items").Item(j + 1).Item("case")) = sRet Then
                           sOut = ExecCommand(this.Item("items").Item(j + 1).Item("return"))
                           Exit For
                        End If
                     Next
                     SB.Append sOut
                  
                  Case "set":
                     If dictVars.Exists(this.Item("name")) Then
                        dictVars.Item(this.Item("name")) = ExecCommand(this.Item("value"))
                     Else
                        dictVars.Add this.Item("name"), ExecCommand(this.Item("value"))
                     End If
                     
                  Case "get":
                     sRet = ExecCommand(dictVars(CStr(this.Item("name"))))
                     If sRet = "" Then
                        sRet = ExecCommand(this.Item("default"))
                     End If
                     
                     SB.Append sRet
                     
                  Case "if"
                     Dim val1 As String
                     Dim val2 As String
                     Dim bRes As Boolean
                     val1 = ExecCommand(this.Item("value1"))
                     val2 = ExecCommand(this.Item("value2"))
                     
                     bRes = False
                     Select Case LCase(this.Item("type"))
                     Case "eq" ' =
                        If LCase(val1) = LCase(val2) Then
                           bRes = True
                        End If
                        
                     Case "gt" ' >
                        If val1 > val2 Then
                           bRes = True
                        End If
                     
                     Case "lt" ' <
                        If val1 < val2 Then
                           bRes = True
                        End If
                     
                     Case "gte" ' >=
                        If val1 >= val2 Then
                           bRes = True
                        End If
                     
                     Case "lte" ' <=
                        If val1 <= val2 Then
                           bRes = True
                        End If
                     
                     End Select
                     
                     If bRes Then
                        SB.Append ExecCommand(this.Item("true"))
                     Else
                        SB.Append ExecCommand(this.Item("false"))
                     End If
                     
                  Case "return"
                     SB.Append obj.Item(key)
                  
                     
                  Case Else
                     If TypeName(this) = "Dictionary" Then
                        paramKeys = this.keys
                        For j = 0 To this.Count - 1
                           If j > 0 Then
                              sRet = sRet & ","
                           End If
                           sRet = sRet & CStr(this.Item(paramKeys(j)))
                        Next
                     End If
                     
                     
                     SB.Append "<%" & UCase(key) & "(" & sRet & ")%>"
                     
                  End Select
               Next i
               
            ElseIf TypeName(obj) = "Collection" Then
   
               Dim Value
               For Each Value In obj
                  SB.Append ExecCommand(Value)
               Next Value
               
            End If
            Set this = Nothing
   
         Case vbBoolean
            If obj Then SB.Append "true" Else SB.Append "false"
         
         Case vbVariant, vbArray, vbArray + vbVariant
         
         Case Else
            SB.Append Replace(obj, ",", ".")
      End Select
      plNestCount = plNestCount - 1
   End If
   
   ExecCommand = SB.toString
   Set SB = Nothing
   
End Function