【下载文档:  asp_JSON类源码分享.txt 】

---

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 %>