asp操作json类，asp实现json转换

调用函数主要用这两个就行了，默认都是包了双引号的，如果数字不需要引号，可设置类中的quota=true

 

'将一个字典或数组打印为jsonstr
Function aspjsonPrint(objs) 
	dim json:Set json = new aspjsonClass
	aspjsonPrint = json.print(objs)
	set json=nothing
End Function

'将一个jsonstr转换为字典对象
Function aspjsonParse(strng)
	dim json:Set json = new aspjsonClass
	if left(strng,1)="[" then
		aspjsonParse = json.parse(strng)
	ElseIf Left(strng,1)="{" Then
		set aspjsonParse = json.parse(strng)
	Else
		Set aspjsonparse = CreateObject("scripting.dictionary")
	end if
	set json=nothing
End Function

Function NewOption()
　　Dim oDic : Set oDic = CreateObject("scripting.dictionary")
　　Set NewOption = oDic
End Function

　　

 

Class aspjsonClass
	Dim isencode
	Dim quota

	Private Sub Class_Initialize()
		quota = True
	End Sub

	Function parse(objs)
		Dim J,isrearr,retobj
		If TypeName(objs)="String" Then
			If Left(objs,1)="[" Then isrearr = "1":objs = "{""_vbarray_"":" & objs & "}"
			Set J = parsejson(objs)
		Else
			Set J = objs
		End If
		Set retobj = json_to_dict(J)
		If isrearr = "1" Then 
			parse = retobj("_vbarray_")
		Else
			Set parse = retobj
		End If
	End Function

	Function parsejson(strjson)
		On Error Resume Next : Err.clear
		Dim obj:Set obj = CreateObject("MSScriptControl.ScriptControl")
		obj.Language = "JScript"  
		obj.ExecuteStatement "var result=" & strjson & ";"
		Set parsejson = obj.CodeObject.result
		Set obj=Nothing
		If Err.number <> 0 Then Set parsejson=Nothing
	End Function

	Function print(objs)
		Dim result,line(),ix, oo,vbtp,jstp,vbtpid :ix=0 : oo=""""
		vbtpid = VarType(objs)
		If vbtpid=14 Then
			vbtp = "Numeric"
		Else
			vbtp = TypeName(objs)
		End If

		If vbtp = "JScriptTypeInfo" Then
			jstp = "object"
			If isJsArray(objs) Then jstp = "array"
		End If

		If vbtp="Nothing" Then
			result = oo & "Null" & oo
		ElseIf jstp = "object" Then
			result = print_json(objs)
		ElseIf vbtp="Dictionary" Then
			For Each strKey In objs.Keys
				redim preserve line(ix)
				line(ix) = oo & strKey & oo & ":" & print(objs(strKey)):ix=ix+1
			Next
			result = "{" & Join(line,",") & "}"
		ElseIf vbtp = "Variant()" Or jstp = "array" Then
			For Each strVal In objs
				redim preserve line(ix)
				line(ix) = print(strVal):ix=ix+1
			Next
			result = "[" & Join(line,",") & "]"
		ElseIf vbtp = "String" Or vbtp="Date" Then
			result = oo & encode(objs) & oo
		ElseIf quota=False And vbtp="Null" Then
			result = "null"
		ElseIf quota=False And inArray(Array("Boolean","Integer","Double","Float","Long","Single","Numeric","Currency"),vbtp ) Then
			If vbtp="Boolean" Then objs=LCase(objs)
			result = objs
		Else
			'If vbtp="Boolean" Then objs=LCase(objs)
			result = oo & objs  & oo				
		End If
		print = result
	End Function

	Private Function json_to_dict(jsjson) 'json对象转字典
		Dim str,obj : Set obj = CreateObject("MSScriptControl.ScriptControl")
		str = str & "function json_to_dict(J){"
		str = str & "var dic = new ActiveXObject('Scripting.Dictionary'),ipos = 0;"
		str = str & "if( Object.prototype.toString.call(J) === '[object Array]' ){"
		str = str & "	for(var cur in J){"
		str = str & "	if(typeof J[cur]=='object'){"
		str = str & "		dic.add(ipos,json_to_dict(J[cur]));"
		str = str & "	}else{"
		str = str & "		dic.add(ipos,J[cur]);"
		str = str & "	}ipos++}dic = dic.Items();"
		str = str & "}else{"
		str = str & "	for (var strkey in J){"
		str = str & "	if(J[strkey]===null){"
		str = str & "		dic.add(strkey, '')"
		str = str & "	}else if(typeof J[strkey]=='object'){"
		str = str & "		dic.add(strkey, json_to_dict(J[strkey]));"
		str = str & "	}else{"
		str = str & "		dic.add(strkey, J[strkey])"
		str = str & "	}}"
		str = str & "}return dic;}"
		obj.Language = "JScript"
		obj.AddCode str
		Set json_to_dict = obj.Run("json_to_dict", jsjson)
		Set obj=Nothing
	End Function

	Private Function isJsArray(objarr)
		On Error Resume Next
		Dim str,obj : Set obj = CreateObject("MSScriptControl.ScriptControl")
		str = str & "function isArray(obj){"
		str = str & "  return Object.prototype.toString.call(obj) === '[object Array]';"
		str = str & "}"		
		obj.Language = "JScript"
		obj.AddCode str
		isJsArray = obj.Run("isArray", objarr)
		Set obj=Nothing
	End Function

	Private	Function print_json(jsjson)
		On Error Resume Next : Err.clear
		Dim str,obj : Set obj = CreateObject("MSScriptControl.ScriptControl")
		str = str & "function print_json(objs){"
		str = str & "	var line = [], oo='\""',result='';"
		str = str & "   if(!objs){"
		str = str & "       result = oo + 'Null' + oo;"
		str = str & "	}else if(Object.prototype.toString.call(objs) === '[object Array]'){"
		str = str & "		  for (var i in objs) {"
		str = str & "			  line.push( print_json( objs[i] ) );"
		str = str & "		  }result = '[' + line.join(',') + ']';"
		str = str & "	}else if(typeof(objs)=='object'){"
		str = str & "		for (var obj in objs) {"
		str = str & "			line.push(oo + obj + oo + ':' + print_json( objs[obj] ));"
		str = str & "		}result = '{' + line.join(',') + '}';"
		str = str & "	}else{"
		str = str & "		result = oo + encode(objs) + oo;"
		str = str & "	}return result;"
		str = str & "}"
		str = str & "function encode(value){"
		str = str & "	value = value.replace(/\f/g,'\\f');"
		str = str & "	value = value.replace(/\n/g,'\\n');"
		str = str & "	value = value.replace(/\r/g,'\\r');"
		str = str & "	value = value.replace(/\t/g,'\\t');"
		str = str & "	value = value.replace(/\p/g,'\\p');"
		str = str & "	value = value.replace(/""/g,'\\""');"
		str = str & "	return value;"
		str = str & "}"
		obj.Language = "JScript"
		obj.AddCode str
		print_json = obj.Run("print_json", jsjson)
		Set obj=Nothing
	End Function

	Private Function encode(ByVal value)
		value = Trim(value & "")
		value = Replace(value, "\", "\\")
		value = Replace(value, """", "\""")
		value = Replace(value, Chr(8), "\b")
		value = Replace(value, Chr(12), "\f")
		value = Replace(value, Chr(10), "\n")
		value = Replace(value, Chr(13), "\r")
		encode = Replace(value, Chr(9), "\t")
	End Function
End Class