MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
661
Hi,
i am experimenting with the following:

Code:
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
 

Some videos you may like

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,126
It might be something like this, but without further details of your URL or API I can't be specific.

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

    xmlhttp.setRequestHeader "Authorization", "Basic " & EncodeBase64(username & ":" & password)
Code:
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

Well-known Member
Joined
Nov 16, 2016
Messages
661
Hi @JohnW
I got this to load as intended and the authentication works.

Code:
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
 
Last edited:

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,126
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:

Code:
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:

Code:
    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:
Code:
    Debug.Print Json("web-app")("servlet")(1)("servlet-name")
 

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
661
Thanks @JohnW this is a great help

The comments from my result look like this (the data i need in rows),
Code:
("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?
 
Last edited:

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,126
The Dictionary and Collection data structures created by ParseJson have a Count property, so try this:
Code:
    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

Well-known Member
Joined
Nov 16, 2016
Messages
661
Thanks again, i got it working as intended using this

Code:
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

Well-known Member
Joined
Nov 16, 2016
Messages
661
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")
 
Last edited:

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,126
Prepend the value with an apostrophe or set the cell's format to text:
Code:
Range("C2").Value = "'" & Json("Index")(1)("Name")(2)("Result")

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

Watch MrExcel Video

Forum statistics

Threads
1,089,850
Messages
5,410,747
Members
403,328
Latest member
dalan

This Week's Hot Topics

Top