Como Utilizar JSON en Macros VBA

Cuando utilizamos macros normalmente es para hacer tareas más complejas como accesar a bases de datos, utilizar tablas dinámicas, crear contenido dinámico, utilizar webservices, obtener datos directamente de la web, etc. En esto último no es una tarea tan fácil de manejar en VBA ya que cuando hacemos una consulta en la web muy pocas veces la respuesta es directa si no que la mayoría de las veces son textos JSON y en VBA no existe una función que nos permita utilizar JSON.
Para poder utilizar textos JSON en VBA podemos hacer uso de librerías (clases), una forma de usar JSON es la siguiente.

  1. Crear una clase de preferencia llamada “json” y agregarle el siguiente código que encontré aquí, este código es el que se encarga de convertir el texto JSON en un objeto Dictionary

    Option Explicit
    
    Const INVALID_JSON      As Long = 1
    Const INVALID_OBJECT    As Long = 2
    Const INVALID_ARRAY     As Long = 3
    Const INVALID_BOOLEAN   As Long = 4
    Const INVALID_NULL      As Long = 5
    Const INVALID_KEY       As Long = 6
    
    Private Sub Class_Initialize()
    
    End Sub
    
    Private Sub Class_Terminate()
    
    End Sub
    
    '
    '   parse string and create JSON object (Dictionary or Collection in VB)
    '
    Public Function parse(ByRef str As String) As Object
    
        Dim index As Long
        index = 1
        
        On Error Resume Next
    
        Call skipChar(str, index)
        Select Case Mid(str, index, 1)
        Case "{"
            Set parse = parseObject(str, index)
        Case "["
            Set parse = parseArray(str, index)
        End Select
    
    End Function
    
    '
    '   parse collection of key/value (Dictionary in VB)
    '
    Private Function parseObject(ByRef str As String, ByRef index As Long) As Object
    
        Set parseObject = CreateObject("Scripting.Dictionary")
        
        ' "{"
        Call skipChar(str, index)
        If Mid(str, index, 1) <> "{" Then Err.Raise vbObjectError + INVALID_OBJECT, Description:="char " & index & " : " & Mid(str, index)
        index = index + 1
        
        Do
        
            Call skipChar(str, index)
            If "}" = Mid(str, index, 1) Then
                index = index + 1
                Exit Do
            ElseIf "," = Mid(str, index, 1) Then
                index = index + 1
                Call skipChar(str, index)
            End If
            
            Dim key As String
            
            ' add key/value pair
            parseObject.Add key:=parseKey(str, index), Item:=parseValue(str, index)
            
        Loop
    
    End Function
    
    '
    '   parse list (Collection in VB)
    '
    Private Function parseArray(ByRef str As String, ByRef index As Long) As Collection
    
        Set parseArray = New Collection
        
        ' "["
        Call skipChar(str, index)
        If Mid(str, index, 1) <> "[" Then Err.Raise vbObjectError + INVALID_ARRAY, Description:="char " & index & " : " + Mid(str, index)
        index = index + 1
        
        Do
            
            Call skipChar(str, index)
            If "]" = Mid(str, index, 1) Then
                index = index + 1
                Exit Do
            ElseIf "," = Mid(str, index, 1) Then
                index = index + 1
                Call skipChar(str, index)
            End If
            
            ' add value
            parseArray.Add parseValue(str, index)
            
        Loop
    
    End Function
    
    '
    '   parse string / number / object / array / true / false / null
    '
    Private Function parseValue(ByRef str As String, ByRef index As Long)
    
        Call skipChar(str, index)
        
        Select Case Mid(str, index, 1)
        Case "{"
            Set parseValue = parseObject(str, index)
        Case "["
            Set parseValue = parseArray(str, index)
        Case """", "'"
            parseValue = parseString(str, index)
        Case "t", "f"
            parseValue = parseBoolean(str, index)
        Case "n"
            parseValue = parseNull(str, index)
        Case Else
            parseValue = parseNumber(str, index)
        End Select
    
    End Function
    
    '
    '   parse string
    '
    Private Function parseString(ByRef str As String, ByRef index As Long) As String
    
        Dim quote   As String
        Dim char    As String
        Dim code    As String
        
        Call 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 """", "\\", "/"
                    parseString = parseString & char
                    index = index + 1
                Case "b"
                    parseString = parseString & vbBack
                    index = index + 1
                Case "f"
                    parseString = parseString & vbFormFeed
                    index = index + 1
                Case "n"
                    parseString = parseString & vbNewLine
                    index = index + 1
                Case "r"
                    parseString = parseString & vbCr
                    index = index + 1
                Case "t"
                    parseString = parseString & vbTab
                    index = index + 1
                Case "u"
                    index = index + 1
                    code = Mid(str, index, 4)
                    parseString = parseString & ChrW(val("&h" + code))
                    index = index + 4
                End Select
            Case quote
                index = index + 1
                Exit Function
            Case Else
                parseString = parseString & char
                index = index + 1
            End Select
        Loop
    
    End Function
    
    '
    '   parse number
    '
    Private Function parseNumber(ByRef str As String, ByRef index As Long)
    
        Dim value   As String
        Dim char    As String
        
        Call 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
                    parseNumber = CDbl(value)
                Else
                    parseNumber = CInt(value)
                End If
                Exit Function
            End If
        Loop
    
    
    End Function
    
    '
    '   parse true / false
    '
    Private Function parseBoolean(ByRef str As String, ByRef index As Long) As Boolean
    
        Call skipChar(str, index)
        If Mid(str, index, 4) = "true" Then
            parseBoolean = True
            index = index + 4
        ElseIf Mid(str, index, 5) = "false" Then
            parseBoolean = False
            index = index + 5
        Else
            Err.Raise vbObjectError + INVALID_BOOLEAN, Description:="char " & index & " : " & Mid(str, index)
        End If
    
    End Function
    
    '
    '   parse null
    '
    Private Function parseNull(ByRef str As String, ByRef index As Long)
    
        Call skipChar(str, index)
        If Mid(str, index, 4) = "null" Then
            parseNull = Null
            index = index + 4
        Else
            Err.Raise vbObjectError + INVALID_NULL, Description:="char " & index & " : " & Mid(str, index)
        End If
    
    End Function
    
    Private Function parseKey(ByRef str As String, ByRef index As Long) As String
    
        Dim dquote  As Boolean
        Dim squote  As Boolean
        Dim char    As String
        
        Call 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 skipChar(str, index)
                    If Mid(str, index, 1) <> ":" Then
                        Err.Raise vbObjectError + INVALID_KEY, Description:="char " & index & " : " & parseKey
                    End If
                End If
            Case "'"
                squote = Not squote
                index = index + 1
                If Not squote Then
                    Call skipChar(str, index)
                    If Mid(str, index, 1) <> ":" Then
                        Err.Raise vbObjectError + INVALID_KEY, Description:="char " & index & " : " & parseKey
                    End If
                End If
            Case ":"
                If Not dquote And Not squote Then
                    index = index + 1
                    Exit Do
                End If
            Case Else
                If InStr(vbCrLf & vbCr & vbLf & vbTab & " ", char) Then
                Else
                    parseKey = parseKey & char
                End If
                index = index + 1
            End Select
        Loop
    
    End Function
    
    '
    '   skip special character
    '
    Private Sub skipChar(ByRef str As String, ByRef index As Long)
    
        While index > 0 And index <= Len(str) And InStr(vbCrLf & vbCr & vbLf & vbTab & " ", Mid(str, index, 1))
            index = index + 1
        Wend
    
    End Sub
    
    Public Function toString(ByRef obj As Variant) As String
    
        Select Case VarType(obj)
            Case vbNull
                toString = "null"
            Case vbDate
                toString = """" & CStr(obj) & """"
            Case vbString
                toString = """" & encode(obj) & """"
            Case vbObject
                Dim bFI, i
                bFI = True
                If TypeName(obj) = "Dictionary" Then
                    toString = toString & "{"
                    Dim keys
                    keys = obj.keys
                    For i = 0 To obj.Count - 1
                        If bFI Then bFI = False Else toString = toString & ","
                        Dim key
                        key = keys(i)
                        toString = toString & """" & key & """:" & toString(obj(key))
                    Next i
                    toString = toString & "}"
                ElseIf TypeName(obj) = "Collection" Then
                    toString = toString & "["
                    Dim value
                    For Each value In obj
                        If bFI Then bFI = False Else toString = toString & ","
                        toString = toString & toString(value)
                    Next value
                    toString = toString & "]"
                End If
            Case vbBoolean
                If obj Then toString = "true" Else toString = "false"
            Case vbVariant, vbArray, vbArray + vbVariant
                Dim sEB
                toString = multiArray(obj, 1, "", sEB)
            Case Else
                toString = Replace(obj, ",", ".")
        End Select
    
    End Function
    
    Private Function encode(str) As String
        
        Dim i, j, aL1, aL2, c, p
    
        aL1 = Array(&H22, &H5C, &H2F, &H8, &HC, &HA, &HD, &H9)
        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
                    encode = encode & "\" & 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
                    encode = encode & c
                ElseIf a > -1 Or a < 65535 Then
                    encode = encode & "\u" & String(4 - Len(Hex(a)), "0") & Hex(a)
                End If
            End If
        Next
    End Function
    
    Private 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.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 Function
    

  2. Crear un módulo y agregar la siguiente función para no estar declarando la clase cada vez que le necesitemos y así solamente llamaremos directamente a la función

    Function parseJSON(strJson As String) As Object
        Dim clsJson As json
        Set clsJson = New json
        Set parseJSON = clsJson.parse(strJson)
    End Function
    

  3. Usar la función de la siguiente forma

    Sub PruebaJson()
        Dim strJson As String
        Dim objJson As Object
        strJson = "{""response"": {""id"": ""1"",""value"": ""Código Excel""}}"
        Set objJson = parseJSON(strJson)
        If Not objJson Is Nothing Then
            MsgBox "Mi Blog es " & objJson.Item("response").Item("value")
        End If
    End Sub
    


    Como se puede observar el texto JSON de ejemplo tiene dos comillas dobles esto es porque en VBA para poner comillas en un texto se colocan dos veces, pero si el texto JSON lo obtenemos de la web o de algún archivo solamente debe tener una comilla doble y no dos.
    El texto JSON del ejemplo es el siguiente

    {"response": {
    "id": "1",
    "value": "Código Excel",
    }}

    Si queremos obtener el elemento “value” necesitamos pasar por todos los elementos superiores hasta llegar a “value”, en esta caso solamente hay un elemento superior llamado “response” y por eso se utiliza
    objJson.Item(“response”).Item(“value”) que nos da como resultado Código Excel

  4. Anuncios

6 pensamientos en “Como Utilizar JSON en Macros VBA

  1. Pingback: Obtener datos de página web (Convertidor de Divisas) | Código Excel

  2. Hola como obtengo el Valué del Id 2 Y SU RESPUESTA SERIA Código Excel JSON
    {“response”: {
    “id”: “1”,
    “value”: “Código Excel”,
    “id”: “2”,
    “value”: “Código Excel JSON”,
    }}

    Agradecería tu Apoyo gracias

    • Hola.
      El JSON que muestras no es correcto, no puedes utilizar el mismo key varias veces, en este caso estas usando 2 veces el key “id” y también 2 veces el key “value”.
      Lo que puedes hacer es modificar el JSON de la siguiente manera
      {“response”: {
      “0”: {“id”: “1”, “value”: “Código Excel”},
      “1”: {“id”: “2”, “value”: “Código Excel JSON”},
      }}

      Y obtener el valor con objJson.Item(“response”).Item(“1”).Item(“value”)

      • esta todo como en tu código, el problema es que cuando pasa del modulo de clase el objeto llenado al modulo json pierde el objeto. cosa muy rara. Lo he solucionado pasando el objeto byref desde la llamada del modulo asi lo guarda en cada cambio. También para que funcione con keys dentro de keys he duplicado la función parsejson con un nuevo objeto porque sobreescribía el objeto y se quedaban solo las subclaves de una clave. Ahora funciona correctamente. si te interesa te adjunto los cambios y mirais a ver si hay una solución mejor
        Saludos 😉

Responder

Introduce tus datos o haz clic en un icono para iniciar sesión:

Logo de WordPress.com

Estás comentando usando tu cuenta de WordPress.com. Cerrar sesión /  Cambiar )

Google+ photo

Estás comentando usando tu cuenta de Google+. Cerrar sesión /  Cambiar )

Imagen de Twitter

Estás comentando usando tu cuenta de Twitter. Cerrar sesión /  Cambiar )

Foto de Facebook

Estás comentando usando tu cuenta de Facebook. Cerrar sesión /  Cambiar )

Conectando a %s