Announcement

Collapse
No announcement yet.

Need some help to convert JSON parser

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Need some help to convert JSON parser

    No one found in the forum but found one for VB6 on the internet. http://www.ediy.co.nz/vbjson-json-pa...xidc55680.html

    Converted it to PB as far as I could. It seems to work in general. but some things remain such as CreateObject ("Scripting.Dictionary")
    have tried to replace this with "PowerCollection" but without success. There are a few more things but can probably move on if this is solved

    Thanks in advance

    Code:
    '
    ' Original from VB6, VBA JSON at http://www.ediy.co.nz/vbjson-json-parser-library-in-vb6-xidc55680.html
    ' Test/Validate JSON https://jsonlint.com/
    '
    #COMPILE EXE "JSON.EXE"
    #DIM ALL
    #INCLUDE "Win32Api.inc"
    
    FUNCTION PBMAIN () AS LONG
    DIM JSON AS JSONInterface
    JSON = CLASS "clsJSON"
    LOCAL p AS STRING 'variant / object
    LOCAL sText AS STRING
    
    ' ///*** TEST EXAMPLE ***///
    '----------------------------------
    'sText = "{"
    'sText = sText & " 'object_or_array': 'object',"
    'sText = sText & " 'empty': false,"
    'sText = sText & " 'parse_time_nanoseconds': 19608,"
    'sText = sText & " 'validate': true,"
    'sText = sText & " 'size': 1"
    'sText = sText & " }"
    '----------------------------------
    'sText = " {'menu': {"
    'sText = sText & " 'id': 'file',"
    'sText = sText & " 'value': 'File', "
    'sText = sText & " 'popup': { "
    'sText = sText & " 'menuitem': [ "
    'sText = sText & " {'value': 'New', 'onclick': 'CreateNewDoc()'}, "
    'sText = sText & " {'value': 'Open', 'onclick': 'OpenDoc()'}, "
    'sText = sText & " {'value': 'Close', 'onclick': 'CloseDoc()'} "
    'sText = sText & " ] "
    'sText = sText & " } "
    'sText = sText & " }} "
    '----------------------------------
    'sText = "[{""name"":""jack""},{""name"":""john""},{""name"":""joe""}]"
    '----------------------------------
    'sText = "{""pets"":[{""name"":""jack""},{""name"":""john""},{""name"":""joe""}]}"
    '----------------------------------
    sText ="{ width: '200', frame: false, height: 130, bodyStyle:'background-color: #ffffcc;',buttonAlign:'right', items: [{ xtype: 'form', url: '/content.asp'},{ xtype: 'form2', url: '/content2.asp'}] }"
    
    p = JSON.parse( sText )
    '? P
    '? "Parsed object output: " & JSON.toString(p)
    '? "Get Bodystyle data: " & p.Item("bodyStyle")
    '? "Get Form Url data: " & p.Item("items").Item(1).Item("url")
    
    'p.Item("items").Item(1).Add "ExtraItem", "Extra Data Value"
    
    '? "Parsed object output with added item: " & JSON.toString(p)
    END FUNCTION
    
    
    '/////////////////////////////////////////////////////////////////////////////////////////////////////////
    '-------------------------- JSON CLASS -------------------------------------------------------------------
    '/////////////////////////////////////////////////////////////////////////////////////////////////////////
    CLASS clsJSON
    INSTANCE INVALID_JSON AS LONG
    INSTANCE INVALID_OBJECT AS LONG
    INSTANCE INVALID_ARRAY AS LONG
    INSTANCE INVALID_BOOLEAN AS LONG
    INSTANCE INVALID_NULL AS LONG
    INSTANCE INVALID_KEY AS LONG
    INSTANCE m_Default AS STRING
    INSTANCE FALSE AS BYTE
    INSTANCE TRUE AS BYTE
    
    
    '------------------------------------------------------------
    ' Private Class methods
    '------------------------------------------------------------
    
    CLASS METHOD CREATE() ' Constructor
    ' Initialize default properties
    INVALID_JSON = 1
    INVALID_OBJECT = 2
    INVALID_ARRAY = 3
    INVALID_BOOLEAN = 4
    INVALID_NULL = 5
    INVALID_KEY = 6
    
    FALSE = 0
    TRUE = NOT FALSE
    
    END METHOD
    
    CLASS METHOD DESTROY() ' DeConstructor
    ' Do cleanup
    
    END METHOD
    
    CLASS METHOD fvErr(BYREF sErr AS STRING )
    ? sErr
    END METHOD
    
    '---------------------------------------------------------------------------------------------------------
    ' parse collection of key/value (Dictionary in VB)
    '
    CLASS METHOD parseObject(BYREF str AS STRING, BYREF index AS LONG) AS STRING 'OBJECT
    
    'SET parseObject = CreateObject("Scripting.Dictionary")
    LOCAL parseObject AS IPOWERCOLLECTION
    LET parseObject = CLASS "PowerCollection"
    
    ' "{"
    CALL me.skipChar(str, index)
    IF MID$(str, index, 1) <> "{" THEN me.fvErr( STR$(ERR) & " INVALID_OBJECT / Description:=char " & STR$(index) & " : " & MID$(str, index) )
    index = index + 1
    
    DO
    
    CALL me.skipChar(str, index)
    IF "}" = MID$(str, index, 1) THEN
    index = index + 1
    EXIT DO
    ELSEIF "," = MID$(str, index, 1) THEN
    index = index + 1
    CALL me.skipChar(str, index)
    END IF
    
    DIM key AS STRING
    
    ' add key/value pair
    'parseObject.Add key = me.parseKey(str, index), ITEM = me.parseValue(str, index)
    
    'ParseObject.Add( me.parseKey(str, index) , me.parseValue(str, index) )
    
    '***** For test SHOW Key and Value ******
    ? me.parseKey(str, index) & " | " & me.parseValue(str, index)
    
    LOOP
    
    END METHOD
    
    '---------------------------------------------------------------------------------------------------------
    ' parse list (Collection in VB)
    '
    CLASS METHOD parseArray(BYREF str AS STRING, BYREF index AS LONG) AS STRING 'Collection
    
    'SET parseArray = NEW Collection
    LOCAL pArray AS STRING
    
    ' "["
    CALL me.skipChar(str, index)
    IF MID$(str, index, 1) <> "[" THEN me.fvErr( STR$( ERR) & " INVALID_ARRAY, Description:=char " & STR$(index) & " : " + MID$(str, index) )
    index = index + 1
    
    DO
    
    CALL me.skipChar(str, index)
    IF "]" = MID$(str, index, 1) THEN
    index = index + 1
    EXIT DO
    ELSEIF "," = MID$(str, index, 1) THEN
    index = index + 1
    CALL me.skipChar(str, index)
    ELSEIF index > LEN(str) THEN
    me.fvErr( "Missing ']' " )
    EXIT DO
    END IF
    
    ' add value
    'parseArray.Add parseValue(str, index)
    pArray = pArray & me.parseValue(str, index)
    LOOP
    METHOD = pArray
    END METHOD
    
    '---------------------------------------------------------------------------------------------------------
    ' parse string / number / object / array / true / false / null
    '
    CLASS METHOD parseValue(BYREF str AS STRING, BYREF index AS LONG) AS STRING
    
    CALL me.skipChar(str, index)
    
    SELECT CASE MID$(str, index, 1)
    CASE "{"
    'SET parseValue = parseObject(str, index)
    METHOD = me.parseObject(str, index)
    CASE "["
    ' SET parseValue = parseArray(str, index)
    METHOD = me.parseArray(str, index)
    CASE """", "'"
    ' parseValue = parseString(str, index)
    METHOD = me.parseString(str, index)
    CASE "t", "f"
    'parseValue = parseBoolean(str, index)
    METHOD = STR$( me.parseBoolean(str, index) )
    CASE "n"
    'parseValue = parseNull(str, index)
    METHOD = me.parseNull(str, index)
    CASE ELSE
    'parseValue = parseNumber(str, index)
    METHOD = me.parseNumber(str, index)
    END SELECT
    
    END METHOD
    
    '---------------------------------------------------------------------------------------------------------
    ' parse string
    '
    CLASS METHOD parseString(BYREF str AS STRING, BYREF index AS LONG) AS STRING
    
    DIM quote AS STRING
    DIM char AS STRING
    DIM CODE AS STRING
    LOCAL SB AS STRING
    
    CALL me.skipChar(str, index)
    quote = MID$(str, index, 1)
    index = index + 1
    
    DO WHILE index > 0 AND index <= LEN(str)
    char = MID$(str, index, 1)
    SELECT CASE (char)
    CASE "\"
    index = index + 1
    char = MID$(str, index, 1)
    SELECT CASE (char)
    CASE """", "\\", "/"
    SB = SB & char
    index = index + 1
    CASE "b"
    SB =SB & $BS
    index = index + 1
    CASE "f"
    SB = SB & $FF
    index = index + 1
    CASE "n"
    SB = SB & $LF
    index = index + 1
    CASE "r"
    SB = SB & $CR
    index = index + 1
    CASE "t"
    SB = SB & $TAB
    index = index + 1
    CASE "u"
    index = index + 1
    CODE = MID$(str, index, 4)
    SB = SB & CHR$(VAL("&h" + CODE))
    index = index + 4
    END SELECT
    CASE quote
    index = index + 1
    METHOD = SB
    EXIT METHOD
    CASE ELSE
    SB = SB & char
    index = index + 1
    END SELECT
    LOOP
    METHOD = SB
    END METHOD
    
    '---------------------------------------------------------------------------------------------------------
    ' parse number
    '
    CLASS METHOD parseNumber(BYREF str AS STRING, BYREF index AS LONG) AS STRING
    
    DIM value AS STRING
    DIM char AS STRING
    
    CALL me.skipChar(str, index)
    DO WHILE index > 0 AND index <= LEN(str)
    char = MID$(str, index, 1)
    IF INSTR("+-0123456789.eE", char) THEN
    value = value & char
    index = index + 1
    ELSE
    'IF INSTR(value, ".") OR INSTR(value, "e") OR INSTR(value, "E") THEN
    'method = CDBL(value)
    ' METHOD = value
    'ELSE
    'METHOD = CINT(value)
    'END IF
    METHOD = Value
    EXIT METHOD
    END IF
    LOOP
    
    END METHOD
    
    '---------------------------------------------------------------------------------------------------------
    ' parse true / false
    '
    CLASS METHOD parseBoolean(BYREF str AS STRING, BYREF index AS LONG) AS INTEGER 'Boolean
    
    CALL me.skipChar(str, index)
    IF MID$(str, index, 4) = "true" THEN
    METHOD = True
    index = index + 4
    ELSEIF MID$(str, index, 5) = "false" THEN
    METHOD = False
    index = index + 5
    ELSE
    me.fvErr ( STR$(ERR) & " INVALID_BOOLEAN Description:= char " & STR$(index) & " : " & MID$(str, index) )
    END IF
    
    END METHOD
    
    '---------------------------------------------------------------------------------------------------------
    ' parse null
    '
    CLASS METHOD parseNull(BYREF str AS STRING, BYREF index AS LONG) AS STRING
    
    CALL me.skipChar(str, index)
    IF MID$(str, index, 4) = "null" THEN
    'me.parseNull = $NUL
    METHOD = $NUL
    index = index + 4
    ELSE
    me.fvErr(STR$(ERR) & " INVALID_NULL Description:=char " & STR$(index) & " : " & MID$(str, index) )
    
    END IF
    
    END METHOD
    
    '---------------------------------------------------------------------------------------------------------
    ' Parse KEY
    '
    CLASS METHOD parseKey(BYREF str AS STRING, BYREF index AS LONG) AS STRING
    
    DIM dquote AS INTEGER 'Boolean
    DIM squote AS INTEGER 'Boolean
    DIM char AS STRING
    LOCAL pKey AS STRING ' parseKey
    
    CALL me.skipChar(str, index)
    DO WHILE index > 0 AND index <= LEN(str)
    char = MID$(str, index, 1)
    SELECT CASE (char)
    CASE """"
    dquote = NOT dquote
    index = index + 1
    IF NOT dquote THEN
    CALL me.skipChar(str, index)
    IF MID$(str, index, 1) <> ":" THEN
    me.fvErr (STR$(ERR) & STR$(INVALID_KEY) & " Description:=char " & STR$(index) & " : "& pKey )
    END IF
    END IF
    CASE "'"
    squote = NOT squote
    index = index + 1
    IF NOT squote THEN
    CALL me.skipChar(str, index)
    IF MID$(str, index, 1) <> ":" THEN
    me.fvErr (STR$(ERR) & STR$(INVALID_KEY) & " Description:=char " & STR$(index) & " : " & pKey )
    END IF
    END IF
    CASE ":"
    IF NOT dquote AND NOT squote THEN
    index = index + 1
    METHOD = pKey
    EXIT DO
    END IF
    CASE ELSE
    IF INSTR($CRLF & $CR & $LF & $TAB & " ", char) THEN
    ELSE
    pKey = pKey & char
    END IF
    index = index + 1
    END SELECT
    LOOP
    
    END METHOD
    
    '---------------------------------------------------------------------------------------------------------
    ' skip special character
    '
    CLASS METHOD skipChar(BYREF str AS STRING, BYREF index AS LONG)
    
    WHILE index > 0 AND index <= LEN(str) AND INSTR($CRLF & $CR & $LF & $TAB & " ", MID$(str, index, 1))
    index = index + 1
    WEND
    
    END METHOD
    
    
    '---------------------------------------------------------------------------------------------------------
    '
    '
    CLASS METHOD encode(vstr AS VARIANT ) AS STRING
    
    LOCAL i, j, p, a, aL1, aL2 AS LONG
    LOCAL enc, c, sStr AS STRING
    DIM aL1(10) AS LONG
    DIM aL2(10) AS LONG
    
    sStr = VARIANT$(vStr)
    ARRAY ASSIGN aL1()= &H22, &H5C, &H2F, &H8, &HC, &HA, &HD, &H9
    ARRAY ASSIGN aL2()= &H22, &H5C, &H2F, &H62, &H66, &H6E, &H72, &H74
    FOR i = 1 TO LEN(sstr)
    p = True
    c = MID$(sstr, i, 1)
    FOR j = 0 TO 7
    IF c = CHR$( aL1(j) ) THEN
    enc = enc & "\" & CHR$(aL2(j))
    p = False
    EXIT FOR
    END IF
    NEXT
    
    IF p THEN
    a = ASC(c)
    IF a > 31 AND a < 127 THEN
    enc = enc & c
    ELSEIF a > -1 OR a < 65535 THEN
    enc = enc & "\u" & STRING$(4 - LEN( HEX$(a) ), "0") & HEX$(a)
    END IF
    END IF
    NEXT
    END METHOD
    
    '---------------------------------------------------------------------------------------------------------
    
    ' CLASS METHOD 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.Number = 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 & toString(Eval("aBD(" & sPB2 & ")"))
    ' multiArray = multiArray & toString(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
    ' Err.Clear
    ' END METHOD
    
    
    
    '------------------------------------------------------------
    ' End of Private Class methods
    '------------------------------------------------------------
    '------------------------------------------------------------
    ' Public Interface
    '------------------------------------------------------------
    INTERFACE JSONInterface: INHERIT IUNKNOWN
    
    PROPERTY GET Defa() AS STRING
    PROPERTY = m_Default
    END PROPERTY
    
    PROPERTY SET Defa( BYVAL sDefault AS STRING )
    m_Default = RTRIM$(sDefault)
    END PROPERTY
    
    ' ----------------------------------------------------------------------------------------------------
    ' parse string and create JSON object (Dictionary or Collection in VB)
    '
    METHOD PARSE(BYREF str AS STRING) AS STRING 'OBJECT
    
    DIM index AS LONG
    index = 1
    
    'ON ERROR RESUME NEXT
    
    CALL me.skipChar(str, index)
    SELECT CASE MID$(str, index, 1)
    CASE "{"
    METHOD = me.parseObject(str, index)
    
    CASE "["
    METHOD = me.parseArray(str, index)
    END SELECT
    
    END METHOD
    
    ' ----------------------------------------------------------------------------------------------------
    '
    '
    METHOD toString(BYREF obj AS VARIANT) AS STRING
    'LOCAL SB AS IPOWERCOLLECTION
    'LET SB = CLASS "StringBuilder"
    LOCAL SB AS STRING
    
    SELECT CASE VARIANT#(obj)
    CASE %VT_NULL 'vbNull
    SB = SB & "null"
    CASE %VT_DATE ' vbDate
    METHOD = "??" '"""" & CStr(obj) & """"
    CASE %VT_BSTR 'vbString
    SB = SB & """" & me.encode(obj) & """"
    CASE %VT_STREAMED_OBJECT 'vbObject
    LOCAL bFI AS INTEGER 'BOOLEAN
    LOCAL i AS LONG
    bFI = True
    'IF VARIANT#(obj) = "Dictionary" THEN
    ' if bFI = 2 then // dummy , skall vara raden ovan
    METHOD = "{"
    DIM keys(100) AS LONG
    'keys = obj.keys
    ' FOR i = 0 TO obj.Count - 1
    ' IF bFI THEN bFI = False ELSE SB.append ","
    DIM key AS LONG
    key = keys(i)
    'SB.append """" & key & """:" & SB.append(obj(key))
    ' NEXT i
    ' SB.append "}"
    'ELSEIF VARIANT#(obj) = "Collection" THEN
    ' SB.append "["
    ' DIM value
    ' FOR EACH value IN obj
    ' IF bFI THEN bFI = False ELSE SB.append ","
    ' toString = toString & toString(value)
    ' NEXT value
    ' SB.append "]"
    'END IF
    CASE %VT_BOOL 'vbBoolean
    'IF obj THEN SB = SB & "true" ELSE SB = SB & "false"
    'CASE vbVariant, vbArray, vbArray + vbVariant
    ' DIM sEB
    ' FUNCTION = multiArray(obj, 1, "", sEB)
    CASE ELSE
    REPLACE ANY "," WITH "." IN SB
    END SELECT
    METHOD = SB
    
    END METHOD
    
    END INTERFACE
    '------------------------------------------------------------
    ' End of Public Interface
    '------------------------------------------------------------
    END CLASS

  • #2

    Any idea what to replace CreateObject ("Scripting.Dictionary") if PowerCollection does not work?

    Thanks in advance

    Comment


    • #3
      What exactly "does not work"?

      PB's PowerCollection ofc has different properties/method's than the Dictionary object

      Comment


      • #4

        I do not get ParseObject.Add (me.parseKey (str, index), me.parseValue (str, index)) to work.
        Have experimented with lots of variants with no results.

        Found something like "Poly Bag" that I will look into. Can it work? Is it better for the purpose?

        Comment


        • #5
          That's still very vague.

          For a starter, your parseKey returns a STRING value, whereas the .Add method of the PowerCollection object expects the key parameter as a WSTRING, Similar for the value parameter. It's expected to be of type VARIANT, whereas your parseValue method also returns a string. So try converting those to the right data tapyes and see if that helps (PB can be really picky with wrong data types).

          Comment


          • #6
            Don't get it!
            Obviously no one is using json? Which is strange since most Web GUIs seem to be using this?
            Here is a FREE Framework - Web GUI that I want to use, based on json : http://w2ui.com/web/home
            Take a look at some demo examples on the website, think it is outstanding.

            I found a new link for json: Recursive VBA JSON Parser for Excel: https://www.codeproject.com/Articles...rser-for-Excel

            Is it better for my purpose?

            Grateful for some guidance

            Comment


            • #7
              FYI Brian Alvarez wrote a JSON parsing DLL for PB.


              Comment


              • #8
                How is it behaving Shawn?
                www.pluribasic.com

                Comment


                • #9
                  Originally posted by Brian Alvarez View Post
                  How is it behaving Shawn?
                  works every day

                  Comment


                  • #10
                    Haha, 6 months later. You have been busy huh?
                    www.pluribasic.com

                    Comment

                    Working...
                    X