Class aspJSON Public data Private p_JSONstring private aj_in_string, aj_in_escape, aj_i_tmp, aj_char_tmp, aj_s_tmp, aj_line_tmp, aj_line, aj_lines, aj_currentlevel, aj_currentkey, aj_currentvalue, aj_newlabel, aj_XmlHttp, aj_RegExp, aj_colonfound Private Sub Class_Initialize() Set data = Collection() Set aj_RegExp = new regexp aj_RegExp.Pattern = "\s{0,}(\S{1}[\s,\S]*\S{1})\s{0,}" aj_RegExp.Global = False aj_RegExp.IgnoreCase = True aj_RegExp.Multiline = True End Sub Private Sub Class_Terminate() Set data = Nothing Set aj_RegExp = Nothing End Sub Public Sub loadJSON(URL) inputsource = aj_MultilineTrim(URL)'Webservice If Len(inputsource) = 0 Then Err.Raise 1, "loadJSON Error", "No data to load." Set aj_XmlHttp = CreateObject("MSXML2.ServerXMLHTTP") aj_XmlHttp.open "GET", inputsource, false aj_XmlHttp.setRequestHeader "Content-Type", "application/json" aj_XmlHttp.setRequestHeader "CharSet", "UTF-8" aj_XmlHttp.Send If Len(aj_XmlHttp.responseText) > 0 Then 'Verifica se iniciada com "{" ou "[" if Left(aj_XmlHttp.responseText, 1) = "{" then inputsource = "["+aj_XmlHttp.responseText+"]" else inputsource = aj_XmlHttp.responseText end if set aj_XmlHttp = Nothing p_JSONstring = CleanUpJSONstring(inputsource) aj_lines = Split(p_JSONstring, Chr(13) & Chr(10)) else Msgbox "JSON Vazio" Exit sub end if Dim level(99) aj_currentlevel = 1 Set level(aj_currentlevel) = data For Each aj_line In aj_lines aj_currentkey = "" aj_currentvalue = "" If Instr(aj_line, ":") > 0 Then aj_in_string = False aj_in_escape = False aj_colonfound = False For aj_i_tmp = 1 To Len(aj_line) If aj_in_escape Then aj_in_escape = False Else Select Case Mid(aj_line, aj_i_tmp, 1) Case """" aj_in_string = Not aj_in_string Case ":" If Not aj_in_escape And Not aj_in_string Then aj_currentkey = Left(aj_line, aj_i_tmp - 1) aj_currentvalue = Mid(aj_line, aj_i_tmp + 1) aj_colonfound = True Exit For End If Case "\" aj_in_escape = True End Select End If Next if aj_colonfound then aj_currentkey = aj_Strip(aj_JSONDecode(aj_currentkey), """") If Not level(aj_currentlevel).exists(aj_currentkey) Then level(aj_currentlevel).Add aj_currentkey, "" end if End If If right(aj_line,1) = "{" Or right(aj_line,1) = "[" Then If Len(aj_currentkey) = 0 Then aj_currentkey = level(aj_currentlevel).Count Set level(aj_currentlevel).Item(aj_currentkey) = Collection() Set level(aj_currentlevel + 1) = level(aj_currentlevel).Item(aj_currentkey) aj_currentlevel = aj_currentlevel + 1 aj_currentkey = "" ElseIf right(aj_line,1) = "}" Or right(aj_line,1) = "]" or right(aj_line,2) = "}," Or right(aj_line,2) = "]," Then aj_currentlevel = aj_currentlevel - 1 ElseIf Len(Trim(aj_line)) > 0 Then if Len(aj_currentvalue) = 0 Then aj_currentvalue = aj_line aj_currentvalue = getJSONValue(aj_currentvalue) If Len(aj_currentkey) = 0 Then aj_currentkey = level(aj_currentlevel).Count level(aj_currentlevel).Item(aj_currentkey) = aj_currentvalue End If Next End Sub Public Function Collection() set Collection = CreateObject("Scripting.Dictionary") End Function Public Function AddToCollection(dictobj) if TypeName(dictobj) <> "Dictionary" then Err.Raise 1, "AddToCollection Error", "Not a collection." aj_newlabel = dictobj.Count dictobj.Add aj_newlabel, Collection() set AddToCollection = dictobj.item(aj_newlabel) end function Private Function CleanUpJSONstring(aj_originalstring) aj_originalstring = Replace(aj_originalstring, Chr(13) & Chr(10), "") aj_originalstring = Mid(aj_originalstring, 2, Len(aj_originalstring) - 2) aj_in_string = False : aj_in_escape = False : aj_s_tmp = "" For aj_i_tmp = 1 To Len(aj_originalstring) aj_char_tmp = Mid(aj_originalstring, aj_i_tmp, 1) If aj_in_escape Then aj_in_escape = False aj_s_tmp = aj_s_tmp & aj_char_tmp Else Select Case aj_char_tmp Case "\" : aj_s_tmp = aj_s_tmp & aj_char_tmp : aj_in_escape = True Case """" : aj_s_tmp = aj_s_tmp & aj_char_tmp : aj_in_string = Not aj_in_string Case "{", "[" aj_s_tmp = aj_s_tmp & aj_char_tmp & aj_InlineIf(aj_in_string, "", Chr(13) & Chr(10)) Case "}", "]" aj_s_tmp = aj_s_tmp & aj_InlineIf(aj_in_string, "", Chr(13) & Chr(10)) & aj_char_tmp Case "," : aj_s_tmp = aj_s_tmp & aj_char_tmp & aj_InlineIf(aj_in_string, "", Chr(13) & Chr(10)) Case Else : aj_s_tmp = aj_s_tmp & aj_char_tmp End Select End If Next CleanUpJSONstring = "" aj_s_tmp = split(aj_s_tmp, Chr(13) & Chr(10)) For Each aj_line_tmp In aj_s_tmp aj_line_tmp = replace(replace(aj_line_tmp, chr(10), ""), chr(13), "") CleanUpJSONstring = CleanUpJSONstring & aj_Trim(aj_line_tmp) & Chr(13) & Chr(10) Next End Function Private Function getJSONValue(ByVal val) val = Trim(val) If Left(val,1) = ":" Then val = Mid(val, 2) If Right(val,1) = "," Then val = Left(val, Len(val) - 1) val = Trim(val) Select Case val Case "true" : getJSONValue = True Case "false" : getJSONValue = False Case "null" : getJSONValue = Null Case Else If (Instr(val, """") = 0) Then If IsNumeric(val) Then getJSONValue = CDbl(val) Else getJSONValue = val End If Else If Left(val,1) = """" Then val = Mid(val, 2) If Right(val,1) = """" Then val = Left(val, Len(val) - 1) getJSONValue = aj_JSONDecode(Trim(val)) End If End Select End Function Private JSONoutput_level Public Function JSONoutput() dim wrap_dicttype, aj_label JSONoutput_level = 1 wrap_dicttype = "[]" For Each aj_label In data If Not aj_IsInt(aj_label) Then wrap_dicttype = "{}" Next JSONoutput = Left(wrap_dicttype, 1) & Chr(13) & Chr(10) & GetDict(data) & Right(wrap_dicttype, 1) End Function Private Function GetDict(objDict) dim aj_item, aj_keyvals, aj_label, aj_dicttype For Each aj_item In objDict Select Case TypeName(objDict.Item(aj_item)) Case "Dictionary" GetDict = GetDict & Space(JSONoutput_level * 4) aj_dicttype = "[]" For Each aj_label In objDict.Item(aj_item).Keys If Not aj_IsInt(aj_label) Then aj_dicttype = "{}" Next If aj_IsInt(aj_item) Then GetDict = GetDict & (Left(aj_dicttype,1) & Chr(13) & Chr(10)) Else GetDict = GetDict & ("""" & aj_JSONEncode(aj_item) & """" & ": " & Left(aj_dicttype,1) & Chr(13) & Chr(10)) End If JSONoutput_level = JSONoutput_level + 1 aj_keyvals = objDict.Keys GetDict = GetDict & (GetSubDict(objDict.Item(aj_item)) & Space(JSONoutput_level * 4) & Right(aj_dicttype,1) & aj_InlineIf(aj_item = aj_keyvals(objDict.Count - 1),"" , ",") & Chr(13) & Chr(10)) Case Else aj_keyvals = objDict.Keys GetDict = GetDict & (Space(JSONoutput_level * 4) & aj_InlineIf(aj_IsInt(aj_item), "", """" & aj_JSONEncode(aj_item) & """: ") & WriteValue(objDict.Item(aj_item)) & aj_InlineIf(aj_item = aj_keyvals(objDict.Count - 1),"" , ",") & Chr(13) & Chr(10)) End Select Next End Function Private Function aj_IsInt(val) aj_IsInt = (TypeName(val) = "Integer" Or TypeName(val) = "Long") End Function Private Function GetSubDict(objSubDict) GetSubDict = GetDict(objSubDict) JSONoutput_level= JSONoutput_level -1 End Function Private Function WriteValue(ByVal val) Select Case TypeName(val) Case "Double", "Integer", "Long": WriteValue = val Case "Null" : WriteValue = "null" Case "Boolean" : WriteValue = aj_InlineIf(val, "true", "false") Case Else : WriteValue = """" & aj_JSONEncode(val) & """" End Select End Function Private Function aj_JSONEncode(ByVal val) val = Replace(val, "\", "\\") val = Replace(val, """", "\""") 'val = Replace(val, "/", "\/") val = Replace(val, Chr(8), "\b") val = Replace(val, Chr(12), "\f") val = Replace(val, Chr(10), "\n") val = Replace(val, Chr(13), "\r") val = Replace(val, Chr(9), "\t") aj_JSONEncode = Trim(val) End Function Private Function aj_JSONDecode(ByVal val) val = Replace(val, "\""", """") val = Replace(val, "\\", "\") val = Replace(val, "\/", "/") val = Replace(val, "\b", Chr(8)) val = Replace(val, "\f", Chr(12)) val = Replace(val, "\n", Chr(10)) val = Replace(val, "\r", Chr(13)) val = Replace(val, "\t", Chr(9)) aj_JSONDecode = Trim(val) End Function Private Function aj_InlineIf(condition, returntrue, returnfalse) If condition Then aj_InlineIf = returntrue Else aj_InlineIf = returnfalse End Function Private Function aj_Strip(ByVal val, stripper) If Left(val, 1) = stripper Then val = Mid(val, 2) If Right(val, 1) = stripper Then val = Left(val, Len(val) - 1) aj_Strip = val End Function Private Function aj_MultilineTrim(TextData) aj_MultilineTrim = aj_RegExp.Replace(TextData, "$1") End Function private function aj_Trim(val) aj_Trim = Trim(val) Do While Left(aj_Trim, 1) = Chr(9) : aj_Trim = Mid(aj_Trim, 2) : Loop Do While Right(aj_Trim, 1) = Chr(9) : aj_Trim = Left(aj_Trim, Len(aj_Trim) - 1) : Loop aj_Trim = Trim(aj_Trim) end function End Class Sub Vazia() End Sub