乐码库:一个极速、放心、纯净的下载站! 更新: 资源发布
  • 您的位置:首页 > 技术文档 > ASP编程 > ASPJSON类源码分享
  • 收藏本页
      ASPJSON类源码分享
      发布时间:2016-10-27 05:33:22 关键词: ASP,JSON
      内容简介: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 
    %> 
    
      最新更新
      热门排行榜