ASP JSON类源码分享

代码如下：

<% 
'============================================================ 
' 文件名称 : /Cls_Json.asp 
' 文件作用 : 系统JSON类文件 
' 文件版本 : VBS JSON(JavaScript Object Notation) Version 2.0.2 
' 程序修改 : Cloud.L 
' 最后更新 : 2009-05-12 
'============================================================ 
' 程序核心 : JSON官方　http://www.json.org/ 
' 作者博客 : Http://www.cnode.cn 
'============================================================ 
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 
%>