MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

[JumboCactuar]

Hi,
i am experimenting with the following:

Sub testXMLHTTP_VBA()Dim xmlhttp As Object, myurl As String


Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
myurl = "https://www.mrexcel.com/forum/excel-questions/"
xmlhttp.Open "GET", myurl, False
xmlhttp.Send
MsgBox (xmlhttp.responseText)
End Sub

I read i can add authentication this way by encoding the user and pass as Base64? But unsure how

Also getting the result as JSON, which i can somehow integrate this: xmlhttp.setRequestHeader "Content-Type", "text/json"

Does anyone have any knowledge of this?

Any help appreciated

 

[John_w]

It might be something like this, but without further details of your URL or API I can't be specific.

    Dim username As String, password As String
    username = "user123": password = "abc123"

    xmlhttp.setRequestHeader "Authorization", "Basic " & EncodeBase64(username & ":" & password)

Private Function EncodeBase64(plainText As String) As String

    Dim bytes() As Byte
    Dim objXML As Object 'MSXML2.DOMDocument60
    Dim objNode As Object 'MSXML2.IXMLDOMNode
    
    bytes = StrConv(plainText, vbFromUnicode)
   
    Set objXML = CreateObject("MSXML2.DOMDocument.6.0")
    Set objNode = objXML.createElement("b64")
    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = bytes
    EncodeBase64 = objNode.Text
    
    Set objNode = Nothing
    Set objXML = Nothing
    
End Function

There is a JSON parser at https://github.com/VBA-tools/VBA-JSON/blob/master/JsonConverter.bas

 

[JumboCactuar]

Not tested yet but this is just what I need thanks @John_w

 

[JumboCactuar]

Hi @JohnW
I got this to load as intended and the authentication works.

Sub JSON1()
    Dim username As String, password As String
    username = "xxx"
    password = "xxx"
    
Dim xmlhttp As Object, myurl As String

Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
myurl = Range("C1")
xmlhttp.Open "GET", myurl, False
xmlhttp.setRequestHeader "Authorization", "Basic " & EncodeBase64(username & ":" & password)
xmlhttp.setRequestHeader "Accept", "application/json"
xmlhttp.Send
Range("A1") = xmlhttp.responseText

'Dim Json As Object
'Set Json = JsonConverter.ParseJson(xmlhttp.responseText)


End Sub

Though do you know how to output the JSON as a table? Or how to parse everything to cells

The above currently outputs entire JSON to A1

 

[John_w]

I wrote this JSONToCells function to output a parsed JSON structure (created by JsonConverter.ParseJson) to cells in a hierarchical layout starting at the specified destination cell and return the number of rows written:

Public Function JSONToCells(JSONvar As Variant, destinationCell As Range, Optional ByVal path As String) As Long

    Dim n As Long, i As Long
    Dim key As Variant

    n = 0

    If varType(JSONvar) = vbObject Then 'Dictionary or Collection
    
        If TypeName(JSONvar) = "Dictionary" Then
            If JSONvar.Count = 0 Then n = 1
            For Each key In JSONvar.keys
                destinationCell.Offset(n, 0).Value = key
                n = n + JSONToCells(JSONvar(key), destinationCell.Offset(n, 1), path & "(""" & key & """)")
            Next
        ElseIf TypeName(JSONvar) = "Collection" Then
            If JSONvar.Count = 0 Then n = 1
            For i = 1 To JSONvar.Count
                destinationCell.Offset(n, 0).Value = i
                n = n + JSONToCells(JSONvar(i), destinationCell.Offset(n, 1), path & "(" & i & ")")
            Next
        End If

    ElseIf varType(JSONvar) >= vbArray Then 'Variant()

        If UBound(JSONvar) = -1 Then n = 1
        For i = 0 To UBound(JSONvar)
            destinationCell.Offset(n, 0).Value = i
            n = n + JSONToCells(JSONvar(i), destinationCell.Offset(n, 1), path & "(" & i & ")")
        Next

    Else

        destinationCell.Offset(n, 0).NumberFormat = "@"    'text format
        destinationCell.Offset(n, 0).Value = JSONvar
        CreateComment destinationCell.Offset(n, 0), path
        n = n + 1

    End If

    JSONToCells = n

End Function


Private Sub CreateComment(cell As Range, commentText As String)
        
    With cell
        If .Comment Is Nothing Then .AddComment
        .Comment.Visible = False
        .Comment.Text Text:=commentText
        .Comment.Shape.TextFrame.AutoSize = True
    End With
    
End Sub

Call JSONToCells like this:

    Dim Json As Object
    Dim nr As Long
    Set Json = JsonConverter.ParseJson(xmlhttp.responseText)
    With ThisWorkbook.Worksheets(1)
        .Cells.Clear
        nr = JSONToCells(Json, .Range("A1"))
    End With

Notice that JSONToCells calls CreateComment to put a comment at every endpoint value in the hierarchy, showing how to reference that value. For example, if the comment is:

("web-app")("servlet")(1)("servlet-name")

You would reference this particular endpoint value in the parsed Json object like this:

    Debug.Print Json("web-app")("servlet")(1)("servlet-name")

 

[JumboCactuar]

Thanks @JohnW this is a great help

The comments from my result look like this (the data i need in rows),

("Index")(1)
("Index")(1)("Name")(1)("Result")
("Index")(1)("Name")(2)("Result")
("Index")(1)("Name")(3)("Result")
("Index")(1)("Name")(4)("Result")
("Index")(2)
("Index")(2)("Name")(1)("Result")
("Index")(2)("Name")(2)("Result")
("Index")(2)("Name")(3)("Result")
("Index")(2)("Name")(4)("Result")
("Index")(3)
("Index")(3)("Name")(1)("Result")
("Index")(3)("Name")(2)("Result")
("Index")(3)("Name")(3)("Result")
("Index")(3)("Name")(4)("Result")

Where each ("Index")(i) should be a row
e.g
A2 = ("Index")(1)
B2 = ("Index")(1)("Name")(1)("Result")
C2 = ("Index")(1)("Name")(2)("Result")

could i loop this somehow?

 

[John_w]

The Dictionary and Collection data structures created by ParseJson have a Count property, so try this:

    Dim i As Long, n As Long
    For i = 1 To Json("Index").Count
        For n = 1 To Json("Index")(i).("Name").Count
            Debug.Print Json("Index")(i)("Name")(n)("Result")
        Next
    Next

 

[JumboCactuar]

Thanks again, i got it working as intended using this

Sub JSONTESTss()
Dim Json As Object
Set Json = JsonConverter.ParseJson(Range("A1"))
Set WS1 = Sheets("Sheet3")


    Dim i As Long, n As Long
    For i = 1 To Json("Index").Count
    Rw = i + 1


        For n = 1 To Json("Index")(i)("Name").Count
            'Debug.Print Json("Index")(i)("Name")(n)("Result")
            WS1.Cells(Rw, n) = Json("Index")(i)("Name")(n)("Result")
        Next
    Next
    
End Sub

Had to use Rw = i+1 as Row 1 has Headers

 

[JumboCactuar]

Hi @JohnW
Thanks again for your help, the JSON2cells has been very useful.

Just wondering if you can help with this.

if I transfer data from the parse into cells, and the data is mixed letters and numbers. It is sometimes converting it to scientific format like 1.23E+10

Can I somehow force it as text

With:
C2 = Json("Index")(1)("Name")(2)("Result")

 

[John_w]

Prepend the value with an apostrophe or set the cell's format to text:

Range("C2").Value = "'" & Json("Index")(1)("Name")(2)("Result")

'or
Range("C2").NumberFormat = "@"
Range("C2").Value = Json("Index")(1)("Name")(2)("Result")