ASP JSON class Source sharing _ Application Tips

Copy Code code as follows:

<%
'============================================================
' File name:/cls_json.asp
' File function: System JSON class file
' File version: VBS JSON (JavaScript Object notation) version 2.0.2
' Program modification: CLOUD.L
' Last Updated: 2009-05-12
'============================================================
' Program Core: JSON official http://www.json.org/
' Author blog: Http://www.cnode.cn
'============================================================
Class Json_cls

Public Collection
Public Count
Public Quotedvars ' Add quotes for variables
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

' Set Object type
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 > 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 all 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
%>