I have a MS Access project that requires me retrieve and parse a Json object from a URL. I have done parse part, but I cannot figure out the correct way to retrieve the Json from the URL. If I copy and paste the URL on IE, it will automatically download the Json object as .json file for me. I have searched solution by Google, and none of them works for me. I think the problem is that the URL looks like "https://******.com/rest/external/session/123", which is not similar to a standard XML HTTP request URL. So most solutions which use XMLHTTP request does not work for me.
I have tried to use following code to get it from URL. But all I get is homepage DOM tree instead of Json.
Dim wb As XMLHTTP
Set wb = New XMLHTTP
wb.Open "POST", "https://******.com/rest/external/session/123", False
wb.send
Do Until wb.Status = 200 And wb.ReadyState = 4
DoEvents
Loop
Debug.Print wb.responseText
Anyone has any idea about what I should do here?
Any help is appreciated!
Updated:
I have tried both POST and GET http request. And it gave me the same result
Following are the processes captured by fiddler.
This is captured processes if I copy the url directly on IE
This is captured processes if I use the code above
Just explaining the code logic below. You will need to work on it to build your own code.
Option Compare Database
Dim ApiUrl As String
Dim reader As New XMLHTTP60
Dim coll As Collection
Dim Json As New clsJSONParser
Public Sub ApiInitalisation()
ApiUrl = "http://private-anon-73376961e-count.apiary-mock.com/"
End Sub
Public Sub GetPerson()
On Error GoTo cmdLogIn_Click_Err
'For API
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim contact As Variant
Api.ApiInitalisation
ApiUrl = ApiUrl & "users/5428a72c86abcdee98b7e359"
reader.Open "GET", ApiUrl, False
'reader.setRequestHeader "Accept", "application/json"
reader.send
'Temporay variable to store the response
Dim egTran As String
' Add data to Table
If reader.Status = 200 Then
Set db = CurrentDb
Set rs = db.OpenRecordset("tblPerson", dbOpenDynaset, dbSeeChanges)
egTran = "[" & reader.responseText & "]"
Set coll = Json.parse(egTran)
For Each contact In coll
rs.AddNew
rs!FName = contact.Item("name")
rs!Mobile = contact.Item("phoneNumber")
rs!UserID = contact.Item("deviceId")
rs!SID = contact.Item("_id")
rs.Update
Next
Else
MsgBox "Unable to import data."
End If
End Sub
Related
I am not the greatest with vba coding.. some help will be much appreciated.
I have some code that I get via api and the response is returned in JSON. I need this converted so that it can then be inserted into cells. each request is a single response for one address. Please could some help with this.
Code I have done is below that works and gives me the correct response;
Sub api_request()
'Declare variables
Dim xml_obj As MSXML2.XMLHTTP60
'Create a reference to the Microsoft XML library
Set xml_obj = New MSXML2.XMLHTTP60
'Define URL Components
base_url = "https://api.getaddress.io/find/"
param_postcode = InputBox("Postcode Here")
param_postcode_val = "/"
param_number = InputBox("Number or Name")
param_number_val = "/"
param_api = "?api-key="
param_api_Value = "dAAsSIXtn9iKsObVq3L1kA11823=true"
'Combine all the different components into a single URL
api_url = base_url + _
param_postcode + param_postcode_val + _
param_number + param_number_val + _
param_api + param_api_Value
'Open a new request, specify the method and the URL
xml_obj.Open bstrMethod:="GET", bstrURL:=api_url
'Send the request
xml_obj.send
'Print the status response
Debug.Print xml_obj.responseText
End
End Sub
This is the output response text;
{"postcode":"MK13 0EZ","latitude":52.066448,"longitude":-0.783306,"addresses":[{"formatted_address":["10 Meads Close","","","New Bradwell, Milton Keynes","Buckinghamshire"],"thoroughfare":"Meads Close","building_name":"","sub_building_name":"","sub_building_number":"","building_number":"10","line_1":"33 Meads Close","line_2":"","line_3":"","line_4":"","locality":"New Bradwell","town_or_city":"Milton Keynes","county":"Buckinghamshire","district":"Milton Keynes","country":"England"}]}
I need this above output into a worksheet in excel and then any other requests that are done place under the above response and so on.. I really do hope that someone can help me.
Thanks
I won't answer your question directly, but I'll give you a sub that I've used in the past to give you a framework.
Basic Request
Dim XMLPage As New MSXML2.XMLHTTP60
Dim HTMLDoc As New MSHTML.HTMLDocument
Dim Code As String
Dim JSON As Object
Dim Key As Variant
Code = "500002"
XMLPage.Open "GET", "https://api.bseindia.com/BseIndiaAPI/api/StockTrading/w?flag="etype=EQ&scripcode=" & Code, False
XMLPage.send
Set JSON = JsonConverter.ParseJson(XMLPage.responseText)
For Each Key In JSON
Debug.Print Key & ": " & JSON(Key)
Next Key
The link to the JSON converter has been provided by another user in the comments.
I am trying to fill in a search box on a web page that as it is filled in it auto searches for the results. The website is https://pcpartpicker.com/products/motherboard/. If you go there and type in a motherboard manufacturer of motherboard name you can see how it begins to narrow down the possible selections. I have code that will fill in the search box but nothing happens.
Sub GetMotherboards()
Dim ie As InternetExplorer
Set ie = New InternetExplorer
Dim doc As HTMLDocument
Dim objText As DataObject
Dim objArticleContents As Object
Dim objLinksCollection As Object
Dim objToClipBoard As DataObject
Dim r As Object
Dim prodRating As String
Dim prodName As String
Dim lngNumberOfVideos As Long
Dim strURL As String
Dim strNewString As String, strStr As String, strTestChar As String
Dim bFlag As Boolean
strURL = "https://pcpartpicker.com/products/motherboard/" ' Range("J5").Value
With ie
.navigate strURL
.Visible = True
Do While .readyState <> 4: DoEvents: Loop
Application.Wait Now + #12:00:02 AM#
Set doc = ie.document
End With
bFlag = False
With doc
Set objArticleContents = .getElementsByClassName("subTitle__form")
Stop
Set ele = .getElementsByClassName("subTitle__form")(0)
Set form = .getElementsByClassName("subTitle__form")(0).getElementsByClassName("form-label xs-inline")(1)
Set inzputz = ele.getElementsByClassName("text-input")(0)
Call .getElementsByClassName("text-input")(0).setAttribute("placeholder", "MSI B450 TOMAHAWK") '.setAttribute("part_category_search", "MSI B450 TOMAHAWK")
End With
End Sub
After reading some posts here (which I now can't find) my thinking is that there is/ are event listeners and functions that need to be included in this code but that is over my head. Could someone please help me figure this out.
Tim Williams has a post here (an answer to a post) which discussed this but now I can't find it.
You can avoid the expense of a browser and perform the same xhr GET request the page does that returns json. You will need a json parser to handle the response.
Json library:
I use jsonconverter.bas. Download raw code from here and add to standard module called JsonConverter . You then need to go VBE > Tools > References > Add reference to Microsoft Scripting Runtime. Remove the top Attribute line from the copied code.
I show a partial implementation which makes requests for different categories and products and uses both full and partial string searches. It is a partial implementation in that I read responses into json objects and also print the json strings but do not attempt to access all items within json object. That can be refined upon more detail from you. For demo puposes I access ("result")("data") which gives you the price and name info. Part of the original response json has html as value for accessor ("result")("html"). This has description info e.g.Socket/CPU with motherboard items.
Option Explicit
Public Sub ProductSearches()
Dim xhr As Object, category As String, items()
Set xhr = CreateObject("MSXML2.XMLHTTP")
category = "motherboard"
items = Array("Gigabyte B450M DS3H", "MSI B450 TOMAHAWK", "random string")
PrintListings items, xhr, category
category = "memory"
items = Array("Corsair Vengeance") 'partial search
PrintListings items, xhr, category
End Sub
Public Function GetListings(ByVal xhr As Object, ByVal category As String, ByVal item As String) As Object
Dim json As Object
With xhr
.Open "GET", "https://pcpartpicker.com/products/" & category & "/fetch/?xslug=&location=&search=" & item, False
.setRequestHeader "User-Agent", "Mozilla/5.0"
.send
Set json = JsonConverter.ParseJson(.responseText)("result")("data")
Set GetListings = json
End With
End Function
Public Sub PrintListings(ByRef items(), ByVal xhr As Object, ByVal category As String)
'Partially implemented. You need to decide what to do with contents of json object
Dim json As Object, i As Long
For i = LBound(items) To UBound(items)
Set json = GetListings(xhr, category, items(i))
'Debug.Print Len(JsonConverter.ConvertToJson(json)) ' Len(JsonConverter.ConvertToJson(json)) =2 i.e {} then no results
Debug.Print JsonConverter.ConvertToJson(json) 'demo purposes only
'do something with json
Next
End Sub
Json parsing:
Read about using JsonConverter and parsing json in vba here, here and here.
You need to execute the keyup event after you place your value into your textbox.
You can accomplish this by using the execScript method.
So, after you load the webpage, create a variable for your input/textbox. In the below example, it's tb. Set the .Value property to your search text (which I used "MSI") then fire the keyup event via script.
Dim tb As HTMLInputElement
Set tb = IE.document.getElementById("part_category_search")
tb.Value = "MSI"
IE.document.parentWindow.execScript "$('#part_category_search').keyup()"
I am not overly familiar with jQuery, so this script targets all inputs on the webpage. But I've tested it and it works for your search.
Here was the full code I used in testing if you want to shorten yours:
Dim IE As InternetExplorer
Set IE = New InternetExplorer
IE.Visible = True
IE.navigate "https://pcpartpicker.com/products/motherboard/"
Do While IE.Busy Or IE.readyState < 4
DoEvents
Loop
Dim tb As HTMLInputElement
Set tb = IE.document.getElementById("part_category_search")
tb.Value = "MSI"
IE.document.parentWindow.execScript "$('#part_category_search').keyup()"
My objective is to run a search for some data and return the results into an excel table. I'm using the service newsapi.org and using VBA to do this.
I'm sending a XMLHttpRequest to newsapi.org and successfully receiving a (JSON) response, which I am able to save into a file on my desktop. I however cannot import that response into excel as I receive run-time error 13: type mismatch.
Bizarrely when I change my source to a different JSON file, it works. e.g. http://jsonplaceholder.typicode.com/users
So I'm assuming the issue is somewhere around the type of the JSON response I am receiving.
Public Sub xmlhttptutorial()
Dim xmlhttp As Object
Dim myurl As String
Dim JSON As Object
Dim myFile As String
Dim i As Integer
Dim ws As Worksheet
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
Set ws = Sheet2
myFile = "C:\Users\A0781525\Desktop\myFile.txt"
myurl = "https://newsapi.org/v2/everything?q=Ashley%20Madison%20Data%20Breach&"
xmlhttp.Open "GET", myurl, False
xmlhttp.Send
Set JSON = JsonConverter.ParseJson(xmlhttp.ResponseText)
Open myFile For Output As #1: Print #1, xmlhttp.ResponseText: Close #1
i = 2
For Each Item In JSON
Range("A2").Value = Item("articles")("0:")("source")("id:")
Range("A2").Value = Item("articles")("0:")("source")("name")
Range("A2").Value = Item("articles")("0:")("title")
i = i + 1
Next
End Sub
The break occurs at line:
Range("A2").Value = Item("articles")("0:")("source")("id:")
A sample of the JSON file output I receive:
{"status":"ok","totalResults":16,"articles":[{"source":{"id":"mashable","name":"Mashable"},"author":"Jack Morse","title":"Porn site leaks over a million users' private info","description":"The great thing about the internet is that no one has to know you have a serious thing for hentai pornography. Unless, that is, the porn site you have an account on leaks your personal information. Over a million Luscious.net account holders faced that unexpe…","url":"https://mashable.com/article/porn-site-leaks-users-data/","urlToImage":"https://mondrian.mashable.com/2019%252F08%252F20%252F24%252F62fc9aa277d54b2092a39393d2202a62.856fe.jpg%252F1200x630.jpg?signature=MBXieHs3n4uvowiVyV4K8cCO4j4=","publishedAt":"2019-08-20T22:36:24Z","content":"The great thing about the internet is that no one has to know you have a serious thing for hentai pornography. Unless, that is, the porn site you have an account on leaks your personal information. \r\nOver a million Luscious.net account holders faced that unex… [+2840 chars]"}
You are parsing the JSON incorrectly. Probably due to a misunderstanding of how it is constructed.
Try something like:
i = 2
'Cells.Clear
For Each item In JSON("articles")
Cells(i, 1).Value = item("source")("id")
Cells(i, 2).Value = item("source")("name")
Cells(i, 3).Value = item("title")
i = i + 1
Next
The problem is with the way you are trying to access the parsed json elements.
Not having the exact structure of the JSON the best I can do is assume what you need to do is this:
Debug.Print JSON("articles")(1)("source")("id")
To access the first article's id.
or this
For Each item In JSON("articles")
Debug.Print item("source")("id")
Next item
to loop through them
I'm trying to write a function that returns an "htmlDocument" using "HttpWebRequest" instead of a browser but I'm stuck with transferring of innerhtml.
I don't understand how to set value of "mWebPage" because VB doesn't accept "New" for HTMLDocument
I know that I can use "HtmlAgilityPack" but I would like to test my current code, changing only web request and not to change all parsing code.(To do this I need an HtmlDocument)
After this test, I'll try to change also the parsing code.
Function mWebRe(ByVal mUrl As String) As HTMLDocument
Dim request As HttpWebRequest = CType(WebRequest.Create(mUrl), HttpWebRequest)
' Set some reasonable limits on resources used by this request
request.MaximumAutomaticRedirections = 4
request.MaximumResponseHeadersLength = 4
' Set credentials to use for this request.
request.Credentials = CredentialCache.DefaultCredentials
'Here I've tryed many types
Dim mWebPage As HTMLDocument
Try
Dim request2 As HttpWebRequest = WebRequest.Create(mUrl)
Dim response2 As HttpWebResponse = request2.GetResponse()
Dim reader2 As StreamReader = New StreamReader(response2.GetResponseStream())
Dim WebContent As String = reader2.ReadToEnd()
'This is my last attempt
'This gives Null Reference Exception
mWebPage.Body.InnerHtml = WebContent
Catch ex As Exception
MsgBox(ex.ToString)
End Try
Return mWebPage
End Function
I've tryed many ways (also import HTML Object Library) but nothing worked :(
Okay this is becoming more of a hack by the minute, but this should work.
First, you'll need to instantiate your WebBrowser control at the class level:
Private m_objWebBrowser As WebBrowser
Next add an Event Handler for the DocumentCompleted Event that contains all your HTML parsing data. You get an instance of the HtmlDocument using the OpenNew method of the WebBrowser control.
Private Sub HandleParsing(ByVal sender As Object, ByVal e As WebBrowserDocumentCompletedEventArgs)
'Use your code for generating WebContent.
Dim WebContent As String = "<html></html>"
Dim mWebPage As HtmlDocument = DirectCast(sender, WebBrowser).Document.OpenNew(True)
mWebPage.Write(WebContent)
End Sub
Finally, you can trigger all of this by wiring up the Event Handler and navigating to some page or Html file on disk (DocumentCompleted fires asynchronously):
AddHandler m_objWebBrowser.DocumentCompleted, AddressOf HandleParsing
m_objWebBrowser.Navigate("www.google.com")
I found a solution on the web and modified my code as below:
To make it work you must activate reference to "Microsoft HTML object library" (in .Com references)
It is obsolete but it seems to be the only way to make an html document without using webbrowser.
I Hope it helps someone else.
Function mWebRe(ByVal mUrl As String) As MSHTML.HTMLDocument
Dim request As HttpWebRequest = WebRequest.Create(mUrl)
Dim doc As MSHTML.IHTMLDocument2 = New MSHTML.HTMLDocument
' Set some reasonable limits on resources used by this request
request.MaximumAutomaticRedirections = 4
request.MaximumResponseHeadersLength = 4
' Set credentials to use for this request.
request.Credentials = CredentialCache.DefaultCredentials
Try
Dim response As HttpWebResponse = request.GetResponse()
Dim reader As StreamReader = New StreamReader(response.GetResponseStream())
Dim WebContent As String = reader.ReadToEnd()
doc.clear()
doc.write(WebContent)
doc.close()
'To make sure that the data is fully load.
While (doc.readyState <> "complete")
'This for more waiting (if needed)
'System.Threading.Thread.Sleep(1000)
Application.DoEvents()
End While
Catch ex As Exception
MsgBox(ex.ToString)
End Try
Return doc
End Function
I am trying to build Excel page from iTunes query data.
An example for Angry Birds app my query would look like:
https://itunes.apple.com/lookup?id=343200656&country=AL checking Albania iTunes
https://itunes.apple.com/lookup?id=343200656&country=DZ checking Algeria iTunes
... 150 more stores
My question is the most efficient way to do this query and parse response.
I only know how to to xmlhttp query. Please enlighten me as the better way to do this.
I have read some documentation for VB-JSON, Json.net, CDataSet, fastJSON, but cannot figure out how to get started trying those tools. Anyone have more VBA code examples pulling JSON or way to explain usage of these frameworks to a newb?
Dim innerHTML As Object
Dim myText As String
JsonCheck = ""
Set innerHTML = CreateObject("Microsoft.XMLHTTP")
With innerHTML
.Open "GET", iTunesAPI_link, False
.send
myText = .responsetext
End With
Set innerHTML = Nothing
If InStr(myText, ":0") = 20 Then 'no results found
result = "Down"
ElseIf InStr(myText, "Your request produced an error.") = 46 Then 'link error
result = HTMLCheck(human iTunes link)
Else 'found the app
result = call function which parses myText for desired fields
Endif
Here's a basic approach using the scriptcontrol:
Sub Tester()
Dim json As String
Dim sc As Object
Dim o
Set sc = CreateObject("scriptcontrol")
sc.Language = "JScript"
json = HttpGet("https://itunes.apple.com/lookup?id=343200656&country=AL")
'some json property names may be keywords in VBA, so replace with
' something similar....
json = Replace(json, """description""", """description_r""")
Debug.Print json
sc.Eval "var obj=(" & json & ")" 'evaluate the json response
'add some accessor functions
sc.AddCode "function getResultCount(){return obj.resultCount;}"
sc.AddCode "function getResult(i){return obj.results[i];}"
Debug.Print sc.Run("getResultCount")
Set o = sc.Run("getResult", 0)
Debug.Print o.kind, o.features, o.description_r
End Sub
Function HttpGet(url As String) As String
Dim oHTML As Object
Set oHTML = CreateObject("Microsoft.XMLHTTP")
With oHTML
.Open "GET", url, False
.send
HttpGet = .responsetext
End With
End Function
There's a worked-out approach in Codo's answer to this question: Excel VBA: Parsed JSON Object Loop
I had a similar issue with querying Salesforce's REST API and found dealing with JSON through ScriptControl ended up being unmanageable. I used the following library for parsing and converting to JSON and it's worked perfectly for me: https://code.google.com/p/vba-json/.
Dim JSON As New JSONLib
Dim Parsed As Object
Set Parsed = JSON.parse(jsonValue)
Debug.Print Parsed("resultCount")
Debug.Print Parsed("results")(0)
Using that library, I then wrapped up some of the common functionality for making web requests that I think would help you out: https://github.com/timhall/Excel-REST
Using these libraries, your code would look something like the following:
Dim iTunesClient As New RestClient
iTunesClient.BaseUrl = "https://itunes.apple.com/"
Dim Request As New RestRequest
Request.Format = json
Request.Resource = "lookup"
Request.AddQuerystringParam "id", "343200656"
Request.AddQuerystringParam "country", "AL"
Dim Response As RestResponse
Set Response = iTunesClient.Execute(Request)
' => GET https://itunes.apple.com/lookup?id=343200656&country=AL
If Response.StatusCode = 200 Then
' Response.Data contains converted JSON Dictionary/Collection
Debug.Print "Result Count: " & Response.Data("resultCount")
Dim i As Integer
For i = LBound(Response.Data("results")) To UBound(Response.Data("results"))
Debug.Print "Result " & i & ": " & Response.Data("results")(i)
Next i
Else
Debug.Print "Error: " & Response.Content
End If