Using Access VBA to read JSON data (part two) - json
The following subroutine reads Json data from an internet site:
Sub DistanceRetrieve()
Dim url As String, Response As String
Dim PointCordinate As String
Dim WinHttpReq As Object, Json As Object, Paths As Object, Item As Object, NextItem As Object,
Points As Object
Set WinHttpReq = CreateObject("MSXML2.XMLHTTP.6.0")
With WinHttpReq
url = "https://distances.dataloy.com/route/route?point=" & Latitude1 & "," & Longitude1 &
"&point=" & Latitude2 & "," & Longitude2 & "&block_sc=" & BlockSC & "&block_nw=" & BlockNW
&"&block_ne=" & BlockNE
.Open "GET", url, False
.SetRequestHeader "Content-Type", "application/json"
.SetRequestHeader "X-API-Key", "DnqL8TJbh77wn0DphKhhI6GPOy3fnKDt2fDUMB8j"
.Send
If .Status = 200 Then
Response = .ResponseText
Set Json = JsonConverter.ParseJson(Response)
Set Paths = Json("paths")
For Each Item In Paths
Distance = Item("distance")
Set Points = Item("points")
For Each NextItem In Points
PointCoordinate = NextItem("coordinates")
If PointCoordinate = SuezCanalCoordinate Then
MsgBox ("Sues Canal is on route.")
End Sub
End If
Next
MsgBox ("Sues Canal is not on route.")
End Sub
Next
End If
End With
End Sub
N.B. Some variables are declared as public.
The "For Each NextItem In Points" statement gives "Object required" error message when the code is run.
Hereinafter is the first part of the Json data:
{ "info" : { "copyrights" : [ "Viku AS"], "took" : 1346 }, "paths" : [ { "distance" : 10289.034929805617, "bbox" : [ -10.026282, 1.124421, 113.648011, 60.180576], "points" : { "coordinates" :[[4.960373,60.180576],[4.962496,60.162612],[4.986241,60.143381],[4.944009,60.137372],[4.944009,60.137372],[4.10086,59.45105],[4.100343,59.002301],[1.42238,50.973884],[1.328024,50.868336],[1.308167,50.854352],[1.16305,50.752155],[1.065639,50.683556],[0.919434,50.580593],[0.602589,50.517847],[-0.070224,50.384606],[-0.376109,50.333315],[-1.053553,50.219721],[-1.730997,50.106127],[-2.408441,49.992533],[-2.88957,49.908579],[-3.209387,49.787494],[-3.806258,49.561516],[-4.403129,49.335538],[-5.0,49.109559],[-5.51017,48.916407],[-5.861724,48.642143],[-6.169181,48.246339],[-6.476639,47.850535],[-6.784096,47.454732],[-7.091553,47.058928],[-7.39901,46.663124],[-7.706467,46.26732],[-8.013925,45.871517],[-8.321382,45.475713],[-8.628839,45.079909],[-8.936296,44.684106],[-9.243753,44.288302],[-9.55121,43.892498],[-9.858668,43.496694],[-9.891568,43.45434],[-10.023932,43.260722],[-10.026282,42.88182],[-10.026186,42.46553],[-10.026082,42.015288],[-10.025979,41.565047],[-10.025875,41.114806],[-10.025771,40.664564],[-10.025667,40.214323],[-10.025564,39.764081],[-10.02546,39.31384],[-10.025356,38.863598],[-10.025356,38.69584],[-9.998078,38.603524],[-9.908628,38.296362],[-9.78081,37.857447],[-9.652993,37.418532],[-8.509321,36.452241],[-7.973851,36.329996],[-7.438382,36.20775],[-6.902912,36.085504],[-6.367442,35.963259],[-6.200541,35.925156],[-6.100124,35.925653],[-5.749613,35.937037],[-5.608748,35.93671],[-5.551674,35.951129],[-5.508509,35.962488],[-5.469502,35.972753],[-5.427,35.983562],[-5.072639,36.028626],[-4.523336,36.098481],[-3.974033,36.168336],[-3.42473,36.238191],[-2.875427,36.308045],[-2.326124,36.3779],[-2.268051,36.385285],[-2.188115,36.395701],[-2.188115,36.395701],[6.546112,37.329032],[10.409177,37.409177],[32.220277,31.534171],[32.351432,31.366935],[32.367263,31.321183],[32.326332,31.275712],[32.310771,31.256955],[32.306485,31.250784],[32.305175,31.245859],[32.304701,31.240173],[32.304078,31.22865],[32.30432,31.220009],[32.305401,31.193798],[32.30868,31.101482],[32.30884,31.096973],[32.313349,30.959484],[32.315801,30.881891],[32.316749,30.832008],[32.317177,30.818442],[32.317669,30.81143],[32.319202,30.805119],[32.326993,30.777533],[32.335298,30.748205],[32.338183,30.736395],[32.340812,30.72563],[32.342098,30.720024],[32.343728,30.712811],[32.344013,30.705045],[32.342476,30.69789],[32.339344,30.684428],[32.33286,30.65656],[32.326093,30.627388],[32.324259,30.620015],[32.322923,30.616423],[32.315078,30.602051],[32.311989,30.596237],[32.309886,30.591612],[32.308995,30.589652],[32.304839,30.580932],[32.303776,30.570936],[32.303946,30.565621],[32.305155,30.560251],[32.309042,30.549282],[32.312801,30.544911],[32.320118,30.535669],[32.328006,30.526559],[32.33423,30.518056],[32.336188,30.513515],[32.336788,30.512121],[32.33897,30.506124],[32.343769,30.484001],[32.345429,30.476297],[32.349985,30.452174],[32.357802,30.435216],[32.362452,30.41324],[32.365013,30.401903],[32.371307,30.364477],[32.372001,30.362383],[32.372923,30.360631],[32.37432,30.358856],[32.413348,30.314052],[32.442811,30.282656],[32.4683,30.273356],[32.487274,30.267524],[32.506479,30.261663],[32.528893,30.253179],[32.538655,30.242899],[32.55205,30.223001],[32.565398,30.200991],[32.567636,30.193881],[32.568511,30.186485],[32.568866,30.174391],[32.569061,30.165197],[32.569083,30.164319],[32.571572,30.065582],[32.573102,30.053687],[32.583382,29.999835],[32.585442,29.991212],[32.586504,29.984021],[32.587067,29.978722],[32.587502,29.972775],[32.586472,29.964744],[32.58411,29.957644],[32.580461,29.950635],[32.57586,29.943603],[32.571401,29.939105],[32.567231,29.935892],[32.56278,29.931928],[32.559968,29.92972],[32.553295,29.924821],[32.550781,29.920572],[32.546005,29.90946],[32.546005,29.903795],[32.554049,29.852356],[32.553995,29.847614],[32.534316,29.773183],[32.54236,29.63257],[32.544371,29.61334],[32.548393,29.592358],[32.599674,29.480381],[32.614756,29.454118],[32.630844,29.417339],[32.740534,29.181429],[32.820887,29.008613],[32.940536,28.751286],[33.033041,28.592489],[33.181886,28.374556],[33.31458,28.18027],[33.340722,28.15811],[33.36586,28.137718],[33.60102,27.943094],[33.655442,27.898053],[33.674193,27.88355],[33.703706,27.860724],[33.761019,27.809153],[33.815465,27.752737],[33.818462,27.749631],[33.837436,27.72997],[34.074325,27.532797],[34.102887,27.509024],[34.102887,27.509024],[42.75544,14.336583],[43.189582,13.344682],[43.189582,13.344682],[43.185256,13.313807],[43.188028,13.271231],[43.19972,13.234306],[43.340825,12.677617],[43.364873,12.629906],[43.380267,12.599365],[43.469014,12.507192],[43.691211,12.418707],[43.71623,12.408744],[44.142069,12.239163],[44.567907,12.069581],[44.993746,11.9],[45.080711,11.927235],[45.520055,12.064824],[45.9594,12.202414],[46.398745,12.340004],[46.838089,12.477593],[47.277434,12.615183],[47.716778,12.752772],[48.156123,12.890362],[48.595468,13.027952],[49.034812,13.165541],[49.474157,13.303131],[49.913501,13.440721],[50.352846,13.57831],[50.792191,13.7159],[51.231535,13.853489],[51.67088,13.991079],[52.110225,14.128669],[52.549569,14.266258],[52.988914,14.403848],[58.438634,15.679702],[58.438634,15.679702],[80.701832,5.701832],[93.468048,6.26668],[93.644801,6.27979],[94.095453,6.313216],[94.546105,6.346642],[94.996757,6.380069],[95.087901,6.386743],[95.538651,6.419749],[95.6777,6.381267],[96.113066,6.26078],[96.548433,6.140293],[96.983799,6.019807],[97.419165,5.89932],[97.854532,5.778833],[97.977656,5.62999],[98.265553,5.281954],[98.553451,4.933918],[98.841348,4.585882],[99.185654,4.304885],[99.535149,4.019653],[99.738417,3.85376],[99.932689,3.69521],[100.281985,3.410141],[100.63128,3.125072],[100.784531,3.0],[101.0,2.813011],[101.196657,2.711314],[101.448781,2.580933],[101.651348,2.420594],[102.003384,2.139419],[102.028193,2.119605],[102.250359,1.920972],[102.390329,1.853969],[102.79612,1.65972],[102.802769,1.656537],[102.950924,1.561332],[103.149876,1.425921],[103.343872,1.260979],[103.376343,1.233371],[103.465236,1.19105],[103.508891,1.172935],[103.575394,1.14584],[103.616935,1.133238],[103.678364,1.124421],[103.732268,1.127876],[103.788245,1.161041],[103.829739,1.182472],[103.862881,1.19766],[103.881411,1.205894],[103.931297,1.228061],[103.992803,1.250861],[104.055691,1.259842],[104.10683,1.26537],[104.121072,1.267352],[104.161425,1.27297],[104.208418,1.278497],[104.241756,1.284231],[104.272688,1.289551],[104.327282,1.297842],[104.449603,1.40631],[104.530497,1.551922],[104.749777,1.946632],[104.969057,2.341341],[105.078485,2.538313],[105.133782,2.987055],[105.151868,3.133821],[105.387157,3.519243],[105.509613,3.719836],[105.509613,3.719836],[109.625784,12.40235],[113.648011,21.648011]] ....
N.B. Unnecessary part at the data end is truncated.
Related
Excel VBA-JSON: How do loop through an array inside a JSON object?
Consider this JSON object:
{
"fileName": "Batch_01032023_SakerItemData.xlsx",
"fileLocation": "C:\\Temp",
"message": "There are 3 errors. Please correct and try again.",
"error": [
"{Item} failed validation:Item is required.:8",
"{Type} failed validation:Type is required.:8",
"{Class} failed validation:Class is required.:8"
]
}
I am using the JsonConverter from this repo https://github.com/VBA-tools/VBA-JSON
Consider this VBA code:
Dim jsonObject As Object, item As Object
Dim objHTTP As Object
Dim url As String
Dim result As String
Dim async As Boolean
Dim body As String
body = "{""fileLocation"":""{fileLocation}""}"
body = Replace(body, "{fileLocation}", Replace(fileLocation, "\", "\\"))
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
With objHTTP
.Open "POST", url, async
.SetRequestHeader "Content-Type", "application/json"
.SetRequestHeader "Accept", "application/json"
.SetRequestHeader "Authorization", "Basic " + _
Base64Encode(authUser + ":" + authPassword)
.Send body
.waitForResponse
result = .responseText
End With
Set jsonObject = ParseJson(result)
*** What is the syntax here to loop through error object? ****
For Each item In jsonObject("error")(1)
Next
this line Set jsonObject = ParseJson(result) does not throw an error and seems to work, yet when I get to the 'for each' loop, I get Error # 424 'Object Required'.
My question is this: How can I loop through the 'error' array in the 'jsonObject' so that I can display the validation errors to the user? The error array is dynamic.
The key error returns a Collection, so first assign it to a variable declared as Collection...
Dim col As VBA.Collection
Set col = jsonObject("error")
Then loop through each item in the collection...
Dim itm As Variant
For Each itm In col
Debug.Print itm
Next itm
create JSON using JSONCOVERTER
I am wondering to create a json from VBA Outlook to export email as ticket on Osticket System
Everithing working well except when there's multiple attachments
I need to have this syntax
{
"alert": "true",
"autorespond": "true",
"source": "API",
"name": "Angy User",
"email": "Angry#somewhere.com",
"subject": "Help",
"topicId": "1",
"message": "data:text/html,</body></html>Please Help</body></html>",
"attachments": [
{ "MyFile.png": "data:image/png;base64,JVBERi0........." },
{ "MyFile.png": "data:image/png;base64,JVBERi0........." },
]
}
But using my code i get this
{
"alert": "true",
"autorespond": "true",
"source": "API",
"name": "Angy User",
"email": "Angry#somewhere.com",
"subject": "Help",
"topicId": "1",
"message": "data:text/html,</body></html>Please Help</body></html>",
"attachments": [
{ "MyFile.png": "data:image/png;base64,JVBERi0.........",
"MyFile.png": "data:image/png;base64,JVBERi0........." },
]
}
I use this to create the json
Dim Body As New Dictionary
Body.Add "alert", "true"
Body.Add "autorespond", "true"
Body.Add "source", "API"
Body.Add "name", myMsg.SenderName
Body.Add "email", FromAddress
Body.Add "subject", myMsg.Subject
Body.Add "topicId", CStr(rubriq)
Body.Add "message", "data:text/html," & strData 'myMsg.HTMLBody
Body.Add "attachments", Array(Attm1) 'attachments
Dim json As String
json = JsonConverter.ConvertToJson(Body, Whitespace:=" ")
Where the Attm1 is a dictionary filled in FOR loop
Attm1.Add oFile.FileName, "data:" & _
oFile.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_TYPE) & _
";" & "base64," & n.nodeTypedValue
I used this function
https://github.com/VBA-tools/VBA-JSON
The loop code
Dim attachments As New Collection
If myMsg.attachments.Count > 0 Then
Set fs = CreateObject("Scripting.FileSystemObject")
Set nAtt = xmlTicket.createElement("attachments")
nodeTicket.appendChild nAtt
For i = 1 To myMsg.attachments.Count
Set oFile = myMsg.attachments.Item(i)
'I only add attachments up to a limit in size
If oFile.Size <= MAX_ATTACHMENT Then
sTmpFile = fs.GetTempName
oFile.SaveAsFile sTmpFile
'Attachment data is always base64-coded
n.dataType = "bin.base64"
'The ADODB.Stream tweak allows to read binary files
Set data = CreateObject("ADODB.Stream")
data.Type = 1 'Binary
data.Open
data.LoadFromFile sTmpFile
'MSXML will base64-code it for us
n.nodeTypedValue = data.Read
'Using the bin.base64 structure means adding namespace'd attributes.
'For some reason, osTicket will complain for each extra attribute, so
'we get to clean up
n.Attributes.removeNamedItem "dt:dt"
'For some reason, getting the content-type is very unclear in Outlook
Set a = xmlTicket.createAttribute("type")
a.Value = oFile.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_TYPE)
n.Attributes.setNamedItem a
Dim Attm1 As New Dictionary
Attm1.Add oFile.FileName, "data:" & oFile.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_TYPE) & ";" & "base64," & n.nodeTypedValue
Kill sTmpFile
End If
Next
End If
Try something like this. It's easier to manage if you split out the various jobs into separate methods.
Const MAX_ATTACHMENT As Long = 500000 'or whatever
Sub MainSub()
Dim Body As Object, dict As Object, i As Long, json As String
Dim myMsg As Outlook.MailItem
'...
'...
Body.Add "attachments", New Collection
If myMsg.attachments.Count > 0 Then
For i = 1 To myMsg.attachments.Count
Set dict = AttachmentDict(myMsg.attachments.Item(i))
If Not dict Is Nothing Then 'check conversion happened
Body("attachments").Add dict
End If
Next
End If
json = JsonConverter.ConvertToJson(Body, Whitespace:=" ")
'...
'...
End Sub
'create a dictionary from an attachment if it meets the size limit
Function AttachmentDict(att As Outlook.Attachment)
Dim dict As Object, fso As Object, sTmpFile As String
If att.Size < MAX_ATTACHMENT Then
Set dict = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
sTmpFile = fso.GetSpecialFolder(2) & "\" & fso.GetTempName
att.SaveAsFile sTmpFile
dict.Add att.Filename, "data:" & _
att.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_TYPE) & _
";" & "base64," & FileToBase64(sTmpFile)
Set AttachmentDict = dict
End If
End Function
Function FileToBase64(FilePath As String) As String
Const adTypeBinary = 1 ' Binary file is encoded
Dim objXML, objDocElem, objStream
' Open data stream from file
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = adTypeBinary
objStream.Open
objStream.LoadFromFile FilePath
Set objXML = CreateObject("MSXml2.DOMDocument")
Set objDocElem = objXML.createElement("Base64Data")
objDocElem.DataType = "bin.base64"
objDocElem.nodeTypedValue = objStream.Read()
FileToBase64 = objDocElem.Text
End Function
Bitly API call using VBA Excel Macro
I'm trying to make an Excel Macro to automatically shorten URLs in an Excel file.
().
I found existing code however this applies to an old version of the API:
Bitly has instructions on how to connect to the new API version, however these are not written in VBA:
The Bitly API instructions also contain instructions on how to convert a V3 API call to a V4 API call:
I tried to fix this. In Excel I get the error
'{"message":"FORBIDDEN"'
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim objHTTP As Object
Dim Json, URL, result, AccToken, LongURL As String
If Not Intersect(Target, Range("B6:B100")) Is Nothing Then
If Target.Count > 1 Then Exit Sub 'If users selects more than one cell, exit sub to prevent bugs
If Target.Value = Empty Then Exit Sub
AccToken = Sheet1.Range("C4").Value
If AccToken = "" Then
MsgBox "Please enter your Bitly Access Token to get started" & vbCrLf & "hoi"
Exit Sub
End If
LongURL = Target.Value
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
URL = "https://api-ssl.bitly.com/v4/shorten"
objHTTP.Open "POST", URL, LongURL, False
objHTTP.setRequestHeader "Authorization", "Bearer {" & AccToken & "}"
'objHTTP.setRequestHeader "Authorization", "Bearer {TOKEN}"
objHTTP.setRequestHeader "Content-type", "application/json"
objHTTP.send (Json)
result = objHTTP.responseText
Range("C" & Target.Row).Value = Left(result, Len(result) - 1)
Set objHTTP = Nothing
End If
End Sub
AccToken should be without brackets { } like: objHTTP.setRequestHeader "Authorization", "Bearer " & AccToken
You Dim Json but you set no value to this variable (it is empty) and so you send and empty request objHTTP.send (Json).
Your LongURL shoud not go into tho .Open but into your JSON so it needs to be objHTTP.Open "POST", URL, False and Json = "{""long_url"": ""https://dev.bitly.com"", ""domain"": ""bit.ly"", ""group_guid"": ""Ba1bc23dE4F""}"
It should look something like below:
If Not Intersect(Target, Me.Range("B6:B100")) Is Nothing Then
If Target.Count > 1 Then Exit Sub 'If users selects more than one cell, exit sub to prevent bugs
If Target.Value = vbNullString Then Exit Sub
Dim AccToken As String
AccToken = Sheet1.Range("C4").Value
If AccToken = vbNullString Then
MsgBox "Please enter your Bitly Access Token to get started" & vbCrLf & "hoi"
Exit Sub
End If
Dim LongURL As String
LongURL = Target.Value
Dim objHTTP As Object
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
Dim URL As String
URL = "https://api-ssl.bitly.com/v4/shorten"
objHTTP.Open "POST", URL, False
objHTTP.setRequestHeader "Authorization", "Bearer " & AccToken
objHTTP.setRequestHeader "Content-type", "application/json"
Dim Json As String
Json = "{""long_url"": """ & LongURL & """, ""domain"": ""bit.ly"", ""group_guid"": ""Ba1bc23dE4F""}"
objHTTP.send Json
Dim result As String
result = objHTTP.responseText
Me.Range("C" & Target.Row).Value = Left(result, Len(result) - 1)
Set objHTTP = Nothing
End If
VBA to parse data from web API
Public Sub IMPORTMESTER()
Dim xTOK As String
Dim URL As String
Dim httpREQ As Object
Dim JSON As Object
Dim xLINE As Variant
xTOK = "bdj62bzknriy3dd9g561on2xl2"
URL = "https://api.smartsheet.com/2.0/sheets/7352150637471620"
Set httpREQ = CreateObject("MSXML2.XMLHTTP.6.0")
With httpREQ
.Open "GET", URL, False
.setRequestHeader "Authorization", "Bearer " & xTOK
.setRequestHeader "Content-Type", "application/json"
.Send
End With
xLINE = httpREQ.ResponseText
MsgBox ("Complete!")
End Sub
So, Ive returned data I need, but I tried several methods to parse it and paste in excel, but without success. Here is the part of responsetext:
"cells":[{"columnId":2400415921792900,"value":"MWP08","displayValue":"MWP08"},{"columnId":6904015549163396,"value":"A-WP-80301D5D10C00","displayValue":"A-WP-80301D5D10C00"},{"columnId":1274516014950276,"value":"MWP0830W27V50KD","displayValue":"MWP0830W27V50KD"},{"columnId":5778115642320772,"value":"WP08 30W,120-277VAC,Ra70 5000K Clear lens,Dark bronze","displayValue":"WP08 30W,120-277VAC,Ra70 5000K Clear lens,Dark bronze"},{"columnId":3526315828635524,"value":"image002.png","displayValue":"image002.png","formula":"=SYS_CELLIMAGE(\"image002.png\",\"vDOY-InMRamvhitNGotKzb\",35,52,\"image.png\")","image":{"id":"vDOY-InMRamvhitNGotKzb","height":35,"width":52,"altText":"image002.png"}},{"columnId":8029915456006020},{"columnId":711566061528964,"value":1884.0,"displayValue":"1884","linkInFromCell":{"status":"INACCESSIBLE","sheetId":4533800614029188,"rowId":null,"columnId":null,"sheetName":"MLC-Inventory扣减(2019)"}},{"columnId":2963365875214212,"value":"https://mesterleds.com/wp-content/uploads/2017/12/WP01-45W70W.png","displayValue":"https://mesterleds.com/wp-content/uploads/2017/12/WP01-45W70W.png"},{"columnId":7466965502584708},{"columnId":1837465968371588},{"columnId":6341065595742084},{"columnId":4089265782056836},{"columnId":8592865409427332},{"columnId":430091084818308,"value":175.0,"displayValue":"175"},{"columnId":4933690712188804},{"columnId":2681890898503556},{"columnId":7185490525874052},{"columnId":1555990991660932},{"columnId":6059590619031428}]},{"id":7080298036914052,"rowNumber":3,"siblingId":2576698409543556,"expanded":true,"createdAt":"2019-01-31T00:06:35Z","modifiedAt":"2019-02-18T16:56:50Z",
Each row of table I need starts with:"cells';[{" while I only need "displayValue": for columns!
I tried several solutions and suggestions from various threads from StackOverflow but... no luck!
Below is desired output:
Final excel format (unneccessary columns hidden)
If only after displayValue you can use the following with jsonconverter.bas. You add the .bas to your project and then VBE > Tools > References> Add a reference to Microsoft Scripting Runtime.
Option Explicit
Public Sub IMPORTMESTER()
Dim xTOK As String
Dim URL As String
Dim httpREQ As Object
Dim json As Object
Dim xLINE As Variant
xTOK = "token"
URL = "https://api.smartsheet.com/2.0/sheets/7352150637471620"
Set httpREQ = CreateObject("MSXML2.XMLHTTP.6.0")
With httpREQ
.Open "GET", URL, False
.setRequestHeader "Authorization", "Bearer " & xTOK
.setRequestHeader "Content-Type", "application/json"
.send
End With
xLINE = httpREQ.responseText
Set json = JsonConverter.ParseJson(xLINE)("rows")
Dim item As Object, nextitem As Object, i As Long
For Each item In json
For Each nextitem In item("cells")
i = i + 1
ActiveSheet.Cells(i, 1) = nextitem("displayValue")
Next
Next
End Sub
The item you want is nested within the json where {} is a dictionary, and [] is a collection.
Extract data locations from map
I want to extract data from a map then get and store the locations all charging station in a specific state. (eg: https://www.plugshare.com/) How can this be done? I don't mind using any programming language but which one is the best one for this application?
You can retrieve the data directly from https://www.plugshare.com with XHRs. You have to look into a little how does a website work to scrape the data. For any dynamically loaded data you just inspect XHRs the webpage does, find the one containing the relevant data, make the same XHR (either site provides API or not) and parse response. Navigate the page e. g. in Chrome, then open Developer Tools window (F12), Network tab, reload F5 the page and examine XHRs in the list.
There is one of the requests to URL https://www.plugshare.com/api/locations/region?... that returns latitude, longitude and other info for charging stations in a rectangle viewport area with specified coordinates. You can find URL, query parameters and some necessary headers as shown below:
Response is in JSON format:
You need to add basic authorization header to request. To retrieve the credentials go to Sources tab, add XHR Breakpoint for URL contains https://www.plugshare.com/api/locations/region, reload F5 the page, when the page is paused on XHR, follow the Call Stack frame by frame:
Skip any NREUM and nrWrapper objects that are the part of New Relic functionality. Click pretty-print {} to format source. Search e. g. Basic, Authorization or setRequestHeader in the sources, for that particular case first match is found in https://www.plugshare.com/js/main.js?_=1:
Click a station on the map and you get one more XHR appeared with URL like https://www.plugshare.com/api/locations/[id] with detailed information for that station, as shown below:
Response is in JSON format also:
Also you may get data for stations from URL like https://www.plugshare.com/api/stations/[id].
You may use the below VBA code to retrieve info as described above. Import JSON.bas module into the VBA project for JSON processing.
Option Explicit
Sub Test_www_plugshare_com()
Const Transposed = False ' Output option
Const Detailed = True ' Scrape option
Dim sResponse As String
Dim aQryHds()
Dim oQuery As Object
Dim sQuery As String
Dim vRegionJSON
Dim sState As String
Dim aResult()
Dim i As Long
Dim vLocationJSON
Dim aRows()
Dim aHeader()
' Retrieve auth token
XmlHttpRequest "GET", "https://www.plugshare.com/js/main.js?_=1", "", "", "", sResponse
With RegExMatches(sResponse, "var s\=""(Basic [^""]*)"";") ' var s="Basic *";
If .Count > 0 Then
aQryHds = Array( _
Array("Authorization", .Item(0).SubMatches(0)), _
Array("Accept", "application/json") _
)
Else
MsgBox "Can't retrieve auth token"
Exit Sub
End If
End With
' Set query parameters
Set oQuery = CreateObject("Scripting.Dictionary")
With oQuery
.Add "minimal", "1"
.Add "count", "500"
.Add "latitude", "19.697593650121235"
.Add "longitude", "-155.06529816792295"
.Add "spanLng", "0.274658203125"
.Add "spanLat", "0.11878815323507652"
.Add "access", "1,3"
.Add "outlets", "[{""connector"":1},{""connector"":2},{""connector"":3},{""connector"":4},{""connector"":5},{""connector"":6,""power"":0},{""connector"":6,""power"":1},{""connector"":7},{""connector"":8},{""connector"":9},{""connector"":10},{""connector"":11},{""connector"":12},{""connector"":13},{""connector"":14},{""connector"":15}]"
.Add "fast", "add"
End With
sQuery = EncodeQueryParams(oQuery)
' Retrieve a list of stations for the viewport
XmlHttpRequest "GET", "https://www.plugshare.com/api/locations/region?" & sQuery, aQryHds, "", "", sResponse
' Parse JSON response
JSON.Parse sResponse, vRegionJSON, sState
If sState <> "Array" Then
MsgBox "Invalid JSON response"
Exit Sub
End If
' Populate result array
ReDim aResult(UBound(vRegionJSON))
' Extract selected properties from parsed JSON
For i = 0 To UBound(aResult)
Set aResult(i) = ExtractKeys(vRegionJSON(i), Array("id", "name", "latitude", "longitude"))
DoEvents
Next
If Detailed Then
' Populate result array with detailed info for each location
For i = 0 To UBound(aResult)
' Retrieve detailed info for each location
XmlHttpRequest "GET", "https://www.plugshare.com/api/locations/" & aResult(i)("id"), aQryHds, "", "", sResponse
' Parse JSON response
JSON.Parse sResponse, vLocationJSON, sState
If sState = "Object" Then
' Extract selected properties from parsed JSON
Set aResult(i) = ExtractKeys(vLocationJSON, Array("reverse_geocoded_address", "hours", "phone", "description"), aResult(i))
End If
DoEvents
Next
End If
' Convert resulting array to arrays for output
JSON.ToArray aResult, aRows, aHeader
' Output
With ThisWorkbook.Sheets(1)
.Cells.Delete
If Transposed Then
Output2DArray .Cells(1, 1), WorksheetFunction.Transpose(aHeader)
Output2DArray .Cells(1, 2), WorksheetFunction.Transpose(aRows)
Else
OutputArray .Cells(1, 1), aHeader
Output2DArray .Cells(2, 1), aRows
End If
.Columns.AutoFit
End With
MsgBox "Completed"
End Sub
Sub XmlHttpRequest(sMethod As String, sUrl As String, arrSetHeaders, sFormData, sRespHeaders As String, sContent As String)
Dim arrHeader
'With CreateObject("Msxml2.ServerXMLHTTP")
' .SetOption 2, 13056 ' SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS
With CreateObject("MSXML2.XMLHTTP")
.Open sMethod, sUrl, False
If IsArray(arrSetHeaders) Then
For Each arrHeader In arrSetHeaders
.SetRequestHeader arrHeader(0), arrHeader(1)
Next
End If
.send sFormData
sRespHeaders = .GetAllResponseHeaders
sContent = .responseText
End With
End Sub
Function RegExMatches(sText, sPattern, Optional bGlobal = True, Optional bMultiLine = True, Optional bIgnoreCase = True) As Object
With CreateObject("VBScript.RegExp")
.Global = bGlobal
.MultiLine = bMultiLine
.IgnoreCase = bIgnoreCase
.Pattern = sPattern
Set RegExMatches = .Execute(sText)
End With
End Function
Function EncodeQueryParams(oParams As Object) As String
Dim aParams
Dim i As Long
aParams = oParams.Keys()
For i = 0 To UBound(aParams)
aParams(i) = EncodeUriComponent((aParams(i))) & "=" & EncodeUriComponent((oParams(aParams(i))))
Next
EncodeQueryParams = Join(aParams, "&")
End Function
Function EncodeUriComponent(strText As String) As String
Static objHtmlfile As Object
If objHtmlfile Is Nothing Then
Set objHtmlfile = CreateObject("htmlfile")
objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
End If
EncodeUriComponent = objHtmlfile.parentWindow.encode(strText)
End Function
Function ExtractKeys(oSource, aKeys, Optional oTarget = Nothing) As Object
Dim vKey
If oTarget Is Nothing Then Set oTarget = CreateObject("Scripting.Dictionary")
For Each vKey In aKeys
If oSource.Exists(vKey) Then
If IsObject(oSource(vKey)) Then
Set oTarget(vKey) = oSource(vKey)
Else
oTarget(vKey) = oSource(vKey)
End If
End If
Next
Set ExtractKeys = oTarget
End Function
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Change to Const Detailed = False if you have a lot of items for output to prevent application hanging, since XHRs are in synchronous mode. The output for me with specified viewport coordinates is as follows:
BTW, the similar approach applied in other answers.