Class Json_Cls

Public Collection
Public Count
Public QuotedVars '是否为变量增加引号
Public Kind ' 0 = object, 1 = array

Private Sub Class_Initialize
Set Collection = Server.CreateObject(GP_ScriptingDictionary)
QuotedVars = True
Count = 0
End Sub

Private Sub Class_Terminate
Set Collection = Nothing
End Sub

' counter
Private Property Get Counter 
Counter = Count
Count = Count + 1
End Property

' 设置对象类型
Public Property Let SetKind(ByVal fpKind)
Select Case LCase(fpKind)
Case "object":Kind=0
Case "array":Kind=1
End Select
End Property

' - data maluplation
' -- pair
Public Property Let Pair(p, v)
If IsNull(p) Then p = Counter
Collection(p) = v
End Property

Public Property Set Pair(p, v)
If IsNull(p) Then p = Counter
If TypeName(v) <> "Json_Cls" Then
Err.Raise &hD, "class: class", "class object: '" & TypeName(v) & "'"
End If
Set Collection(p) = v
End Property

Public Default Property Get Pair(p)
If IsNull(p) Then p = Count - 1
If IsObject(Collection(p)) Then
Set Pair = Collection(p)
Else
Pair = Collection(p)
End If
End Property
' -- pair
Public Sub Clean
Collection.RemoveAll
End Sub

Public Sub Remove(vProp)
Collection.Remove vProp
End Sub
' data maluplation

' encoding
Public Function jsEncode(str)
Dim i, j, aL1, aL2, c, p

aL1 = Array(&h22, &h5C, &h2F, &h08, &h0C, &h0A, &h0D, &h09)
aL2 = Array(&h22, &h5C, &h2F, &h62, &h66, &h6E, &h72, &h74)
For i = 1 To Len(str)
p = True
c = Mid(str, i, 1)
For j = 0 To 7
If c = Chr(aL1(j)) Then
jsEncode = jsEncode & "\" & Chr(aL2(j))
p = False
Exit For
End If
Next

If p Then 
Dim a
a = AscW(c)
If a > 31 And a < 127 Then
jsEncode = jsEncode & c
ElseIf a > -1 Or a < 65535 Then
jsEncode = jsEncode & "\u" & String(4 - Len(Hex(a)), "0") & Hex(a)
End If 
End If
Next
End Function

' converting
Public Function toJSON(vPair)
Select Case VarType(vPair)
Case 1 ' Null
toJSON = "null"
Case 7 ' Date
' yaz saati problemi var
' jsValue = "new Date(" & Round((vVal - #01/01/1970 02:00#) * 86400000) & ")"
toJSON = """" & CStr(vPair) & """"
Case 8 ' String
toJSON = """" & jsEncode(vPair) & """"
Case 9 ' Object
Dim bFI,i 
bFI = True
If vPair.Kind Then toJSON = toJSON & "[" Else toJSON = toJSON & "{"
For Each i In vPair.Collection
If bFI Then bFI = False Else toJSON = toJSON & ","

If vPair.Kind Then 
toJSON = toJSON & toJSON(vPair(i))
Else
If QuotedVars Then
toJSON = toJSON & """" & i & """:" & toJSON(vPair(i))
Else
toJSON = toJSON & i & ":" & toJSON(vPair(i))
End If
End If
Next
If vPair.Kind Then toJSON = toJSON & "]" Else toJSON = toJSON & "}"
Case 11
If vPair Then toJSON = "true" Else toJSON = "false"
Case 12, 8192, 8204
Dim sEB
toJSON = MultiArray(vPair, 1, "", sEB)
Case Else
toJSON = Replace(vPair, ",", ".")
End select
End Function

Public Function MultiArray(aBD, iBC, sPS, ByRef sPT) ' Array BoDy, Integer BaseCount, String PoSition
Dim iDU, iDL, i ' Integer DimensionUBound, Integer DimensionLBound
On Error Resume Next
iDL = LBound(aBD, iBC)
iDU = UBound(aBD, iBC)

Dim sPB1, sPB2 ' String PointBuffer1, String PointBuffer2
If Err = 9 Then
sPB1 = sPT & sPS
For i = 1 To Len(sPB1)
If i <> 1 Then sPB2 = sPB2 & ","
sPB2 = sPB2 & Mid(sPB1, i, 1)
Next
MultiArray = MultiArray & toJSON(Eval("aBD(" & sPB2 & ")"))
Else
sPT = sPT & sPS
MultiArray = MultiArray & "["
For i = iDL To iDU
MultiArray = MultiArray & MultiArray(aBD, iBC + 1, i, sPT)
If i < iDU Then MultiArray = MultiArray & ","
Next
MultiArray = MultiArray & "]"
sPT = Left(sPT, iBC - 2)
End If
End Function

Public Property Get ToString
ToString = toJSON(Me)
End Property

Public Sub Flush
If TypeName(Response) <> "Empty" Then 
Response.Write(ToString)
ElseIf WScript <> Empty Then 
WScript.Echo(ToString)
End If
End Sub

Public Function Clone
Set Clone = ColClone(Me)
End Function

Private Function ColClone(core)
Dim jsc, i
Set jsc = New Json_Cls
jsc.Kind = core.Kind
For Each i In core.Collection
If IsObject(core(i)) Then
Set jsc(i) = ColClone(core(i))
Else
jsc(i) = core(i)
End If
Next
Set ColClone = jsc
End Function

Public Function QueryToJSON(dbc, sql)
        Dim rs, jsa,col
        Set rs = dbc.Execute(sql)
        Set jsa = New Json_Cls
        jsa.SetKind="array"
        While Not (rs.EOF Or rs.BOF)
                Set jsa(Null) = New Json_Cls
                jsa(Null).SetKind="object"
                For Each col In rs.Fields
                    jsa(Null)(col.Name) = col.Value
                Next
        rs.MoveNext
        Wend
        Set QueryToJSON = jsa
End Function

End Class