MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
609
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
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
5,957
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
609
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
5,957
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
609
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
5,957
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
609
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
609
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
5,957
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")
 

Forum statistics

Threads
1,078,447
Messages
5,340,344
Members
399,370
Latest member
salamon

Some videos you may like

This Week's Hot Topics

  • Problem with Radio Button's format control
    I am creating an employee evaluation template (a sample is below) Column A is the category Column B, C D, E and F will be ratings (unacceptable...
  • Last Display on userform to a Listbox
    [CODE=vba] lstdisplay.ColumnCount = 15 lstdisplay.RowSource = "A1:O600000" [/CODE] So when i do this it Displays everything on the sheet i am...
  • Rename and move files to a new location
    Dear all, I have an excel file with the following information. The actual file name is at column A but i want to rename it using the following...
  • Help with True/False Formula
    Hello! Am stumped how to fix this formula, in which my result returns 'True', but it should return False. =IF(AG2=True...
  • Clear extra characters from a provided range of cells
    Dear All, I have following code which gives me desired output to remove extra characters from a provided range. But it takes too much time when...
  • Help with Current and highest streaks
    Hi there, I've just joined the forum and this is my first post. I've already spent quite a bit of time searching the net and this forum for a...
Top