JSON_2.0.4.asp类文件：
<%
' VBS JSON 2.0.3
' Copyright (c) 2009 Tu餽ul Topuz
' Under the MIT (MIT-LICENSE.txt) license.
Const JSON_OBJECT = 0
Const JSON_ARRAY = 1
Class jsCore
Public Collection
Public Count
Public QuotedVars
Public Kind ' 0 = object, 1 = array
Private Sub Class_Initialize
Set Collection = CreateObject("Scripting.Dictionary")
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
' - 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) <> "jsCore" Then
Err.Raise &hD, "class: class", "Incompatible types: '" & 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
Function jsEncode(str)
Dim charmap(127), haystack()
charmap(8) = "\b"
charmap(9) = "\t"
charmap(10) = "\n"
charmap(12) = "\f"
charmap(13) = "\r"
charmap(34) = "\"""
charmap(47) = "\/"
charmap(92) = "\\"
Dim strlen : strlen = Len(str) - 1
ReDim haystack(strlen)
Dim i, charcode
For i = 0 To strlen
haystack(i) = Mid(str, i + 1, 1)
charcode = AscW(haystack(i)) And 65535
If charcode < 127 Then
If Not IsEmpty(charmap(charcode)) Then
haystack(i) = charmap(charcode)
ElseIf charcode < 32 Then
haystack(i) = "\u" & Right("000" & Hex(charcode), 4)
End If
Else
haystack(i) = "\u" & Right("000" & Hex(charcode), 4)
End If
Next
jsEncode = Join(haystack, "")
End Function
' converting
Public Function toJSON(vPair)
Select Case VarType(vPair)
Case 0 ' Empty
toJSON = "null"
Case 1 ' Null
toJSON = "null"
Case 7 ' Date
' toJSON = "new Date(" & (vPair - CDate(25569)) * 86400000 & ")" ' let in only utc time
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
toJSON = RenderArray(vPair, 1, "")
Case Else
toJSON = Replace(vPair, ",", ".")
End select
End Function
Function RenderArray(arr, depth, parent)
Dim first : first = LBound(arr, depth)
Dim last : last = UBound(arr, depth)
Dim index, rendered
Dim limiter : limiter = ","
RenderArray = "["
For index = first To last
If index = last Then
limiter = ""
End If
On Error Resume Next
rendered = RenderArray(arr, depth + 1, parent & index & "," )
If Err = 9 Then
On Error GoTo 0
RenderArray = RenderArray & toJSON(Eval("arr(" & parent & index & ")")) & limiter
Else
RenderArray = RenderArray & rendered & "" & limiter
End If
Next
RenderArray = RenderArray & "]"
End Function
Public Property Get jsString
jsString = toJSON(Me)
End Property
Sub Flush
If TypeName(Response) <> "Empty" Then
Response.Write(jsString)
ElseIf WScript <> Empty Then
WScript.Echo(jsString)
End If
End Sub
Public Function Clone
Set Clone = ColClone(Me)
End Function
Private Function ColClone(core)
Dim jsc, i
Set jsc = new jsCore
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
End Class
Function jsObject
Set jsObject = new jsCore
jsObject.Kind = JSON_OBJECT
End Function
Function jsArray
Set jsArray = new jsCore
jsArray.Kind = JSON_ARRAY
End Function
Function toJSON(val)
toJSON = (new jsCore).toJSON(val)
End Function
%>
dbclass.asp类文件：
<%
'==========================================================================
'文件名称：clsDbCtrl.asp
'功 能：数据库操作类
'作 者：coldstone (coldstone[在]qq.com)
'程序版本：v1.0.5
'完成时间：2005.09.23
'修改时间：2007.10.30
'版权声明：可以在任意作品中使用本程序代码，但请保留此版权信息。
' 如果你修改了程序中的代码并得到更好的应用，请发送一份给我，谢谢。
'==========================================================================
Dim a : a = CreatConn(0, "bds257174220_db", "localhost", "sa", "xfxfxf") 'MSSQL数据库
'Dim a : a = CreatConn(1, "Data/%TestDB%.mdb", "", "", "") 'Access数据库
'Dim a : a = CreatConn(1, "E:\MyWeb\Data\%TestDB%.mdb", "", "", "mdbpassword")
Dim Conn
'OpenConn() '在加载时就建立的默认连接对象Conn,默认使用数据库a
Sub OpenConn : Set Conn = Oc(a) : End Sub
Sub CloseConn : Co(Conn) : End Sub
Function Oc(ByVal Connstr)
On Error Resume Next
Dim objConn
Set objConn = Server.CreateObject("ADODB.Connection")
objConn.Open Connstr
If Err.number <> 0 Then
Response.Write("<div id=""DBError"">数据库服务器端连接错误，请与网站管理员联系。</div>")
'Response.Write("错误信息：" & Err.Description)
objConn.Close
Set objConn = Nothing
Response.End
End If
Set Oc = objConn
End Function
Sub Co(obj)
On Error Resume Next
Set obj = Nothing
End Sub
Function CreatConn(ByVal dbType, ByVal strDB, ByVal strServer, ByVal strUid, ByVal strPwd)
Dim TempStr
Select Case dbType
Case "0","MSSQL"
TempStr = "driver={sql server};server="&strServer&";uid="&strUid&";pwd="&strPwd&";database="&strDB
Case "1","ACCESS"
Dim tDb : If Instr(strDB,":")>0 Then : tDb = strDB : Else : tDb = Server.MapPath(strDB) : End If
TempStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&tDb&";Jet OLEDB:Database Password="&strPwd&";"
Case "3","MYSQL"
TempStr = "Driver={mySQL};Server="&strServer&";Port=3306;Option=131072;Stmt=; Database="&strDB&";Uid="&strUid&";Pwd="&strPwd&";"
Case "4","ORACLE"
TempStr = "Driver={Microsoft ODBC for Oracle};Server="&strServer&";Uid="&strUid&";Pwd="&strPwd&";"
End Select
CreatConn = TempStr
End Function
Class dbCtrl
Private debug
Private idbConn
Private idbErr
Private Sub Class_Initialize()
debug = true '调试模式是否开启
idbErr = "出现错误："
If IsObject(Conn) Then
Set idbConn = Conn
End If
End Sub
Private Sub Class_Terminate()
Set idbConn = Nothing
If debug And idbErr<>"出现错误：" Then Response.Write(idbErr)
End Sub
Public Property Let dbConn(pdbConn)
If IsObject(pdbConn) Then
Set idbConn = pdbConn
Else
Set idbConn = Conn
End If
End Property
Public Property Get dbErr()
dbErr = idbErr
End Property
Public Property Get Version
Version = "ASP Database Ctrl V1.0 By ColdStone"
End Property
Public Function AutoID(ByVal TableName)
On Error Resume Next
Dim m_No,Sql, m_FirTempNo
Set m_No=Server.CreateObject("adodb.recordset")
Sql="SELECT * FROM ["&TableName&"]"
m_No.Open Sql,idbConn,3,3
If m_No.EOF Then
AutoID=1
Else
Do While Not m_No.EOF
m_FirTempNo=m_No.Fields(0).Value
m_No.MoveNext
If m_No.EOF Then
AutoID=m_FirTempNo+1
End If
Loop
End If
If Err.number <> 0 Then
idbErr = idbErr & "无效的查询条件！<br />"
If debug Then idbErr = idbErr & "错误信息："& Err.Description
Response.End()
Exit Function
End If
m_No.close
Set m_No = Nothing
End Function
Public Function GetRecord(ByVal TableName,ByVal FieldsList,ByVal Condition,ByVal OrderField,ByVal ShowN)
On Error Resume Next
Dim rstRecordList
Set rstRecordList=Server.CreateObject("adodb.recordset")
With rstRecordList
.ActiveConnection = idbConn
.CursorType = 3
.LockType = 3
.Source = wGetRecord(TableName,FieldsList,Condition,OrderField,ShowN)
.Open
If Err.number <> 0 Then
idbErr = idbErr & "无效的查询条件！<br />"
If debug Then idbErr = idbErr & "错误信息："& Err.Description
.Close
Set rstRecordList = Nothing
Response.End()
Exit Function
End If
End With
Set GetRecord=rstRecordList
End Function
Public Function wGetRecord(ByVal TableName,ByVal FieldsList,ByVal Condition,ByVal OrderField,ByVal ShowN)
Dim strSelect
strSelect="select "
If ShowN > 0 Then
strSelect = strSelect & " top " & ShowN & " "
End If
If FieldsList<>"" Then
strSelect = strSelect & FieldsList
Else
strSelect = strSelect & " * "
End If
strSelect = strSelect & " from [" & TableName & "]"
If Condition <> "" Then
strSelect = strSelect & " where " & ValueToSql(TableName,Condition,1)
End If
If OrderField <> "" Then
strSelect = strSelect & " order by " & OrderField
End If
wGetRecord = strSelect
End Function
Public Function GetRecordBySQL(ByVal strSelect)
On Error Resume Next
Dim rstRecordList
Set rstRecordList=Server.CreateObject("adodb.recordset")
With rstRecordList
.ActiveConnection =idbConn
.CursorType = 3
.LockType = 3
.Source = strSelect
.Open
If Err.number <> 0 Then
idbErr = idbErr & "无效的查询条件！<br />"
If debug Then idbErr = idbErr & "错误信息："& Err.Description
.Close
Set rstRecordList = Nothing
Response.End()
Exit Function
End If
End With
Set GetRecordBySQL = rstRecordList
End Function
Public Function GetRecordDetail(ByVal TableName,ByVal Condition)
On Error Resume Next
Dim rstRecordDetail, strSelect
Set rstRecordDetail=Server.CreateObject("adodb.recordset")
With rstRecordDetail
.ActiveConnection =idbConn
strSelect = "select * from [" & TableName & "] where " & ValueToSql(TableName,Condition,1)
.CursorType = 3
.LockType = 3
.Source = strSelect
.Open
If Err.number <> 0 Then
idbErr = idbErr & "无效的查询条件！<br />"
If debug Then idbErr = idbErr & "错误信息："& Err.Description
.Close
Set rstRecordDetail = Nothing
Response.End()
Exit Function
End If
End With
Set GetRecordDetail=rstRecordDetail
End Function
Public Function AddRecord(ByVal TableName, ByVal ValueList)
On Error Resume Next
DoExecute(wAddRecord(TableName,ValueList))
If Err.number <> 0 Then
idbErr = idbErr & "写入数据库出错！<br />"
If debug Then idbErr = idbErr & "错误信息："& Err.Description
'DoExecute "ROLLBACK TRAN Tran_Insert" '如果存在添加事务（事务滚回）
AddRecord = 0
Exit Function
End If
AddRecord = AutoID(TableName)-1
End Function
Public Function wAddRecord(ByVal TableName, ByVal ValueList)
Dim TempSQL, TempFiled, TempValue
TempFiled = ValueToSql(TableName,ValueList,2)
TempValue = ValueToSql(TableName,ValueList,3)
TempSQL = "Insert Into [" & TableName & "] (" & TempFiled & ") Values (" & TempValue & ")"
wAddRecord = TempSQL
End Function
Public Function UpdateRecord(ByVal TableName,ByVal Condition,ByVal ValueList)
On Error Resume Next
DoExecute(wUpdateRecord(TableName,Condition,ValueList))
If Err.number <> 0 Then
idbErr = idbErr & "更新数据库出错！<br />"
If debug Then idbErr = idbErr & "错误信息："& Err.Description
'DoExecute "ROLLBACK TRAN Tran_Update" '如果存在添加事务（事务滚回）
UpdateRecord = 0
Exit Function
End If
UpdateRecord = 1
End Function
Public Function wUpdateRecord(ByVal TableName,ByVal Condition,ByVal ValueList)
Dim TmpSQL
TmpSQL = "Update ["&TableName&"] Set "
TmpSQL = TmpSQL & ValueToSql(TableName,ValueList,0)
TmpSQL = TmpSQL & " Where " & ValueToSql(TableName,Condition,1)
wUpdateRecord = TmpSQL
End Function
Public Function DeleteRecord(ByVal TableName,ByVal IDFieldName,ByVal IDValues)
On Error Resume Next
Dim Sql
Sql = "Delete From ["&TableName&"] Where ["&IDFieldName&"] In ("
If IsArray(IDValues) Then
Sql = Sql & "Select ["&IDFieldName&"] From ["&TableName&"] Where " & ValueToSql(TableName,IDValues,1)
Else
Sql = Sql & IDValues
End If
Sql = Sql & ")"
DoExecute(Sql)
If Err.number <> 0 Then
idbErr = idbErr & "删除数据出错！<br />"
If debug Then idbErr = idbErr & "错误信息："& Err.Description
'DoExecute "ROLLBACK TRAN Tran_Delete" '如果存在添加事务（事务滚回）
DeleteRecord = 0
Exit Function
End If
DeleteRecord = 1
End Function
Public Function wDeleteRecord(ByVal TableName,ByVal IDFieldName,ByVal IDValues)
On Error Resume Next
Dim Sql
Sql = "Delete From ["&TableName&"] Where ["&IDFieldName&"] In ("
If IsArray(IDValues) Then
Sql = Sql & "Select ["&IDFieldName&"] From ["&TableName&"] Where " & ValueToSql(TableName,IDValues,1)
Else
Sql = Sql & IDValues
End If
Sql = Sql & ")"
wDeleteRecord = Sql
End Function
Public Function ReadTable(ByVal TableName,ByVal Condition,ByVal GetFieldNames)
On Error Resume Next
Dim rstGetValue,Sql,BaseCondition,arrTemp,arrStr,TempStr,i
TempStr = "" : arrStr = ""
'给出SQL条件语句
BaseCondition = ValueToSql(TableName,Condition,1)
'读取数据
Set rstGetValue = Server.CreateObject("ADODB.Recordset")
Sql = "Select "&GetFieldNames&" From ["&TableName&"] Where "&BaseCondition
rstGetValue.Open Sql,idbConn,3,3
If rstGetValue.RecordCount > 0 Then
If Instr(GetFieldNames,",")>0 Then
arrTemp = Split(GetFieldNames,",")
For i = 0 To Ubound(arrTemp)
If i<>0 Then arrStr = arrStr &Chr(112)&Chr(112)&Chr(113)
arrStr = arrStr & rstGetValue.Fields(i).Value
Next
TempStr = Split(arrStr,Chr(112)&Chr(112)&Chr(113))
Else
TempStr = rstGetValue.Fields(0).Value
End If
End If
If Err.number <> 0 Then
idbErr = idbErr & "获取数据出错！<br />"
If debug Then idbErr = idbErr & "错误信息："& Err.Description
rstGetValue.close()
Set rstGetValue = Nothing
Exit Function
End If
rstGetValue.close()
Set rstGetValue = Nothing
ReadTable = TempStr
End Function
Public Function C(ByVal ObjRs)
ObjRs.close()
Set ObjRs = Nothing
End Function
Private Function ValueToSql(ByVal TableName, ByVal ValueList, ByVal sType)
Dim StrTemp
StrTemp = ValueList
If IsArray(ValueList) Then
StrTemp = ""
Dim rsTemp, CurrentField, CurrentValue, i
Set rsTemp = Server.CreateObject("adodb.recordset")
With rsTemp
.ActiveConnection = idbConn
.CursorType = 3
.LockType = 3
.Source ="select * from [" & TableName & "] where 1 = -1"
.Open
For i = 0 to Ubound(ValueList)
CurrentField = Left(ValueList(i),Instr(ValueList(i),":")-1)
CurrentValue = Mid(ValueList(i),Instr(ValueList(i),":")+1)
If i <> 0 Then
Select Case sType
Case 1
StrTemp = StrTemp & " And "
Case Else
StrTemp = StrTemp & ", "
End Select
End If
If sType = 2 Then
StrTemp = StrTemp & "[" & CurrentField & "]"
Else
Select Case .Fields(CurrentField).Type
Case 7,133,134,135,8,129,200,201,202,203
If sType = 3 Then
StrTemp = StrTemp & "'"&CurrentValue&"'"
Else
StrTemp = StrTemp & "[" & CurrentField & "] = '"&CurrentValue&"'"
End If
Case 11
If UCase(cstr(Trim(CurrentValue)))="TRUE" Then
If sType = 3 Then
StrTemp = StrTemp & "1"
Else
StrTemp = StrTemp & "[" & CurrentField & "] = 1"
End If
Else
If sType = 3 Then
StrTemp = StrTemp & "0"
Else
StrTemp = StrTemp & "[" & CurrentField & "] = 0"
End If
End If
Case Else
If sType = 3 Then
StrTemp = StrTemp & CurrentValue
Else
StrTemp = StrTemp & "[" & CurrentField & "] = " & CurrentValue
End If
End Select
End If
Next
End With
If Err.number <> 0 Then
idbErr = idbErr & "生成SQL语句出错！<br />"
If debug Then idbErr = idbErr & "错误信息："& Err.Description
rsTemp.close()
Set rsTemp = Nothing
Exit Function
End If
rsTemp.Close()
Set rsTemp = Nothing
End If
ValueToSql = StrTemp
End Function
Private Function DoExecute(ByVal sql)
Dim ExecuteCmd
Set ExecuteCmd = Server.CreateObject("ADODB.Command")
With ExecuteCmd
.ActiveConnection = idbConn
.CommandText = sql
.Execute
End With
Set ExecuteCmd = Nothing
End Function
End Class
%>
调用方法：
<!--#include file="include/dbclass.asp" -->
<!--#include file="include/JSON_2.0.4.asp" -->
<%
OpenConn() '打开数据库连接
Dim db : Set db = New DbCtrl '建立对象
Co(db) : CloseConn() '释放对象，关闭数据库连接
Dim Json,shuzu()
Set Json = jsObject()
'示例1：以下是获取用户一维数组对象，并将转换成JSON格式输出
if false then
Dim rs2
Set rs2 = db.GetRecord("Users","id,username,addtime","utype=2 And islock = 'False'","id Asc", 0)
While Not rs2.eof
Response.Write ("用户名:" & rs2(1) & " 添加时间:" & rs2(2) & "<br />")
Json(NULL) = rs2(1)
rs2.movenext()
Wend
Json.Flush
Set Json = Nothing
db.C(rs2)
end if
'示例2：以下是获取用户二维数组对象，并将转换成JSON格式输出
Function QueryToJSON(dbc,sql)
Dim rs, jsa
Set rs = dbc.Execute(sql)
Set jsa = jsArray()
While Not (rs.EOF Or rs.BOF)
Set jsa(Null) = jsObject()
For Each col In rs.Fields
jsa(Null)(col.Name) = col.Value
Next
rs.MoveNext
Wend
Set QueryToJSON = jsa
End Function
'SQLstr = "select id,username,addtime from Users order by id desc limit 0,100"
SQLstr = "select id,username,addtime from Users order by id desc"
Response.Write QueryToJSON(Conn,SQLstr).Flush
%>