Results 1 to 10 of 10

Thread: MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

  1. #1
    Board Regular
    Join Date
    Nov 2016
    Posts
    605
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    0 Thread(s)

    Default MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

    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

  2. #2
    Board Regular
    Join Date
    Oct 2007
    Posts
    5,837
    Post Thanks / Like
    Mentioned
    8 Post(s)
    Tagged
    2 Thread(s)

    Default Re: MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

    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-JSO...nConverter.bas

  3. #3
    Board Regular
    Join Date
    Nov 2016
    Posts
    605
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    0 Thread(s)

    Default Re: MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

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

  4. #4
    Board Regular
    Join Date
    Nov 2016
    Posts
    605
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    0 Thread(s)

    Default Re: MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

    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 by JumboCactuar; Jul 10th, 2019 at 11:09 AM.

  5. #5
    Board Regular
    Join Date
    Oct 2007
    Posts
    5,837
    Post Thanks / Like
    Mentioned
    8 Post(s)
    Tagged
    2 Thread(s)

    Default Re: MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

    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")

  6. #6
    Board Regular
    Join Date
    Nov 2016
    Posts
    605
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    0 Thread(s)

    Default Re: MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

    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 by JumboCactuar; Jul 10th, 2019 at 05:17 PM.

  7. #7
    Board Regular
    Join Date
    Oct 2007
    Posts
    5,837
    Post Thanks / Like
    Mentioned
    8 Post(s)
    Tagged
    2 Thread(s)

    Default Re: MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

    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

  8. #8
    Board Regular
    Join Date
    Nov 2016
    Posts
    605
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    0 Thread(s)

    Default Re: MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

    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

  9. #9
    Board Regular
    Join Date
    Nov 2016
    Posts
    605
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    0 Thread(s)

    Default Re: MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

    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 by JumboCactuar; Jul 17th, 2019 at 02:18 PM.

  10. #10
    Board Regular
    Join Date
    Oct 2007
    Posts
    5,837
    Post Thanks / Like
    Mentioned
    8 Post(s)
    Tagged
    2 Thread(s)

    Default Re: MSXML2.serverXMLHTTP : Adding Authentication + getting JSON

    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")

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •