I am working on a project where I want to display a google map in a WebBrowser object in on an excel sheet. I have accomplished this using this URL....
http://maps.google.com/?saddr=29.9390146,-90.0696139&daddr=29.962506,-90.1930133&f=d&output=embed
I would like to also display the driving directions only for this same link (or a different one).
I cannot find any info on how to get google maps to return the directions only via URL.
AHIA,
LarryR
You would want to check out the GoogleMaps Api:
Static Map API
Directions API
These API provides you with XML response where you can parse them to get the results displayed.
I made one to find time and distance which you can use as an example:
This is one of my earlier attempts so no XML is used but it will give you an idea how to work with responses from google.
Public Function GMap(origin_address As String, destination_address As String, Optional mode As Integer = 1, Optional datatype As Integer = 1)
Dim surl As String
Dim oXH As Object
Dim bodytxt As String
Dim time_e As String
Dim distanc_e As String
Dim strmode As String
If mode = 1 Then
strmode = "walking"
ElseIf mode = 2 Then
strmode = "driving"
ElseIf mode = 3 Then
strmode = "bicycling"
Else
GMap = "Invalid Mode"
Exit Function
End If
surl = "http://maps.googleapis.com/maps/api/distancematrix/xml?origins=;" & _
Replace(origin_address, " ", "+") & "&destinations=" & Replace(destination_address, " ", "+") & _
"&mode=" & strmode & "&sensor=false&units=metric"
Set oXH = CreateObject("msxml2.xmlhttp")
With oXH
.Open "get", surl, False
.send
bodytxt = .responseText
End With
bodytxt = Right(bodytxt, Len(bodytxt) - InStr(1, bodytxt, "<text>") - 5)
tim_e = Left(bodytxt, InStr(1, bodytxt, "</text>") - 1)
bodytxt = Right(bodytxt, Len(bodytxt) - InStr(1, bodytxt, "<text>") - 5)
distanc_e = Left(bodytxt, InStr(1, bodytxt, "</text>") - 1)
If datatype = 1 Then
GMap = CDbl(Replace(tim_e, "mins", ""))
ElseIf datatype = 2 Then
GMap = CDbl(Replace(distanc_e, "km", ""))
Else
GMap = "Invalid Data"
End If
Set oXH = Nothing
End Function
I have an Excel addin which does what you want: http://www.calvert.ch/geodesix/
Related
I am using QTP/UFT for automating my UI application. I would like to compare the UI values with the values from the REST API response. I'm new to VBScript and I have coded the method to call the REST API and get the response but i'm trying to find a solution how to parse the JSON using VBScript.
Please help me how i could parse the json response? (Code below)
OR if it's easier to accept the REST response in xml and parse it in VBS?
Appreciate your help and ideas. Thanks!
userName = "abc#xyz.com"
password = "blah.123"
acctNumber = "01999994201"
URL1="https://CXaic-blah.blah.ocp.blah.com:243/ic/api/integration/v1/flows/rest/blah_ACCNTSEARCH/1.0/accountSearch?accountNumber="
URL=URL1&acctNumber
Set objXmlHttpMain = CreateObject("Msxml2.ServerXMLHTTP")
on error resume next
objXmlHttpMain.open "GET",URL, False , userName, password
objXmlHttpMain.setRequestHeader "Accept", "application/json"
objXmlHttpMain.setRequestHeader "charset", "UTF-8"
objXmlHttpMain.send
restjsonresp = objXmlHttpMain.responseText
Below is the format of the json response i get:
{
"searchResponse":{
"element":[
{
"accType":"R",
"accountNumber":"1111111",
"accountStatus":"A",
"taxId":""
}
]
}
}
While I don't have QTP/UFT to test or verify the following code, I offer-up these JSON parsing solutions as-is for experimentation...
1) Inject a JScript block into a "htmlfile" object
Dim y, html : Set html = CreateObject("htmlfile")
Dim window : Set window = html.parentWindow
window.execScript "var json=" & restjsonresp & ";var e=new Enumerator(json.searchResponse.element);", "JScript"
While Not window.e.atEnd()
Set y = window.e.item()
Print "acctType: " & y.accType
Print "accountNumber: " & y.accountNumber
Print "accountStatus: " & y.accountStatus
Print "taxId: " & y.taxId
window.e.moveNext
Wend
2) Calling JScript code using the "MSScriptControl.ScriptControl" (requires 32-bit)
Dim x, eng : Set eng = CreateObject("MSScriptControl.ScriptControl")
eng.Language = "JScript"
eng.AddCode "function json() { return " & restjsonresp & "; }"
Dim oResp : Set oResp = eng.Run("json")
For Each x In oResp.searchResponse.element
Print "acctType: " & x.accType
Print "accountNumber: " & x.accountNumber
Print "accountStatus: " & x.accountStatus
Print "taxId: " & x.taxId
Next
3) Injecting a JScript block into "InternetExplorer.Application" (overkill? perfomance hit)
Dim z, objIE : Set objIE = CreateObject("InternetExplorer.Application")
objIE.Navigate2 "about:blank"
objIE.Toolbar = False
objIE.StatusBar = False
objIE.MenuBar = False
Do While objIE.Busy
Wait 1
Loop
objIE.Visible = False
objIE.document.open "text/html"
objIE.document.write "<script type='text/javascript'>document.json=" & restjsonresp & ";document.jsonEnum = new Enumerator(document.json.searchResponse.element);</script>"
objIE.document.close
While Not objIE.document.jsonEnum.atEnd()
Set z = objIE.document.jsonEnum.item()
Print "acctType: " & z.accType
Print "accountNumber: " & z.accountNumber
Print "accountStatus: " & z.accountStatus
Print "taxId: " & z.taxId
objIE.document.jsonEnum.moveNext
Wend
objIE.Quit
4) Using Demon's VbsJson object (a pure VBScript solution; albeit, with more code)
https://github.com/eklam/VbsJson
5) Use regular expressions (only for simple, well-defined JSON responses)
Dim re : Set re = New RegExp
re.IgnoreCase = True
re.Pattern = "\{\s*""searchResponse""\s*\:\s*\{\s*""element""\s*\:\s*\[\s*(\{\s*""accType""\s*\:\s*""(.*)""\s*,\s*""accountNumber""\s*\:\s*""(.*)""\s*,\s*""accountStatus""\s*\:\s*""(.*)""\s*,\s*""taxId""\s*\:\s*""(.*)""\s*\})\s*\]\s*\}\s*\}"
If re.Test(restjsonresp) Then
Dim matches : Set matches = re.Execute(restjsonresp)
Print "acctType: " & matches(0).SubMatches(1)
Print "accountNumber: " & matches(0).SubMatches(2)
Print "accountStatus: " & matches(0).SubMatches(3)
Print "taxId: " & matches(0).SubMatches(4)
End If
6) Convert JSON to XML, then parse the XML (lots of code, potential overkill)
https://github.com/pravynandas/JSONToXML
If you can control the response, and deliver XML instead of JSON, then it may be preferable to stick with XML for VBScript in QTP/UFT. Regardless, I hope something here is helpful.
Enjoy.
I'm getting
run-time error 424
in 68th row (line)
request.Open "GET", Url, False
and I don't know how to fix it.
My previous question I posted ;
How to scrape specific part of online english dictionary?
My final goal is to get result like this;
A B
beginning bɪˈɡɪnɪŋ
behalf bɪˈhæf
behave bɪˈheɪv
behaviour bɪˈheɪvjər
belong bɪˈlɔːŋ
below bɪˈloʊ
bird bɜːrd
biscuit ˈbɪskɪt
Here's code I wrote, and it's mostly based on someone else's code I found on internet.
' Microsoft ActiveX Data Objects x.x Library
' Microsoft XML, v3.0
' Microsoft VBScript Regular Expressions
Sub ParseHelp()
' Word reference from
Dim Url As String
Url = "https://www.oxfordlearnersdictionaries.com/definition/english/" & Cells(ActiveCell.Row, "B").Value
' Get dictionary's html
Dim Html As String
Html = GetHtml(Url)
' Check error
If InStr(Html, "<TITLE>Not Found</Title>") > 0 Then
MsgBox "404"
Exit Sub
End If
' Extract phonetic alphabet from HTML
Dim wrapPattern As String
wrapPattern = "<span class='name' (.*?)</span>"
Set wrapCollection = FindRegexpMatch(Html, wrapPattern)
' MsgBox StripHtml(CStr(wrapCollection(1)))
' Fill phonetic alphabet into cell
If Not wrapCollection Is Nothing Then
Dim wrap As String
On Error Resume Next
wrap = StripHtml(CStr(wrapCollection(1)))
If Err.Number <> 0 Then
wrap = ""
End If
Cells(ActiveCell.Row, "C").Value = wrap
Else
MsgBox "not found"
End If
End Sub
Public Function StripHtml(Html As String) As String
Dim RegEx As New RegExp
Dim sOut As String
Html = Replace(Html, "</li>", vbNewLine)
Html = Replace(Html, " ", " ")
With RegEx
.Global = True
.IgnoreCase = True
.MultiLine = True
.Pattern = "<[^>]+>"
End With
sOut = RegEx.Replace(Html, "")
StripHtml = sOut
Set RegEx = Nothing
End Function
Public Function GetHtml(Url As String) As String
Dim xmlhttp As Object
Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
Dim converter As New ADODB.stream
' Get
request.Open "GET", Url, False
request.send
' raw bytes
converter.Open
converter.Type = adTypeBinary
converter.Write request.responseBody
' read
converter.Position = 0
converter.Type = adTypeText
converter.Charset = "utf-8"
' close
GetHtml = converter.ReadText
converter.Close
End Function
Public Function FindRegexpMatch(txt As String, pat As String) As Collection
Set FindRegexpMatch = New Collection
Dim rx As New RegExp
Dim matcol As MatchCollection
Dim mat As Match
Dim ret As String
Dim delimiter As String
txt = Replace(txt, Chr(10), "")
txt = Replace(txt, Chr(13), "")
rx.Global = True
rx.IgnoreCase = True
rx.MultiLine = True
rx.Pattern = pat
Set matcol = rx.Execute(txt)
'MsgBox "Match:" & matcol.Count
On Error GoTo ErrorHandler
For Each mat In matcol
'FindRegexpMatch.Add mat.SubMatches(0)
FindRegexpMatch.Add mat.Value
Next mat
Set rx = Nothing
' Insert code that might generate an error here
Exit Function
ErrorHandler:
' Insert code to handle the error here
MsgBox "FindRegexpMatch. " & Err.GetException()
Resume Next
End Function
Any kind of help would be greatly appreciated.
The following is an example of how to read in values from column A and write out pronounciations to column B. It uses css selectors to match a child node then steps up to parentNode in order to ensure entire pronounciation is grabbed. There are a number of ways you could have matched on the parent node to get the second pronounciation. Note that I use a parent node and Replace as the pronounciation may span multiple childNodes.
If doing this for lots of lookups please be a good netizen and put some waits in the code so as to not bombard the site with requests.
Option Explicit
Public Sub WriteOutPronounciations()
Dim html As MSHTML.HTMLDocument, i As Long, ws As Worksheet
Dim data As String, lastRow As Long, urls()
Set ws = ThisWorkbook.Worksheets("Sheet1")
lastRow = ws.Cells(ws.rows.Count, "A").End(xlUp).row 'you need at least two words in column A or change the redim.
urls = Application.Transpose(ws.Range("A1:A" & lastRow).Value)
ReDim results(1 To UBound(urls))
Set html = New MSHTML.HTMLDocument
With CreateObject("MSXML2.ServerXMLHTTP")
For i = LBound(urls) To UBound(urls)
.Open "GET", "https://www.oxfordlearnersdictionaries.com/definition/english/" & urls(i), False
.send
html.body.innerHTML = .responseText
data = Replace$(Replace$(html.querySelector(".name ~ .wrap").ParentNode.innerText, "/", vbNullString), Chr$(10), Chr$(32))
results(i) = Right$(data, Len(data) - 4)
Next
End With
With ThisWorkbook.Worksheets(1)
.Cells(1, 2).Resize(UBound(results, 1), 1) = Application.Transpose(results)
End With
End Sub
Required references (VBE>Tools>References):
Microsoft HTML Object Library
Should you go down the API route then here is a small example. You can make 1000 free calls in a month with Prototype account. The next best, depending on how many calls you wish to make looks like the 10,001 calls (that one extra PAYG call halves the price). # calls will be affected by whether word is head word or needs lemmas lookup call first. The endpoint construction you need is GET /entries/{source_lang}/{word_id}?fields=pronunciations though that doesn't seem to filter massively. You will need a json parser to handle the json returned e.g. github.com/VBA-tools/VBA-JSON/blob/master/JsonConverter.bas. Download raw code from there 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.
Option Explicit
Public Sub WriteOutPronounciations()
Dim html As MSHTML.HTMLDocument, i As Long, ws As Worksheet
Dim data As String, lastRow As Long, words()
'If not performing lemmas lookup then must be head word e.g. behave, behalf
Const appId As String = "yourAppId"
Const appKey As String = "yourAppKey"
Set ws = ThisWorkbook.Worksheets("Sheet1")
lastRow = ws.Cells(ws.rows.Count, "A").End(xlUp).row
words = Application.Transpose(ws.Range("A1:A" & lastRow).Value)
ReDim results(1 To UBound(words))
Set html = New MSHTML.HTMLDocument
Dim json As Object
With CreateObject("MSXML2.ServerXMLHTTP")
For i = LBound(words) To UBound(words)
.Open "GET", "https://od-api.oxforddictionaries.com/api/v2/entries/en-us/" & LCase$(words(i)) & "?fields=pronunciations", False
.setRequestHeader "app_id", appId
.setRequestHeader "app_key", appKey
.setRequestHeader "ContentType", "application/json"
.send
Set json = JsonConverter.ParseJson(.responseText)
results(i) = IIf(json("results")(1)("type") = "headword", json("results")(1)("lexicalEntries")(1)("pronunciations")(2)("phoneticSpelling"), "lemmas lookup required")
Set json = Nothing
Next
End With
With ThisWorkbook.Worksheets(1)
.Cells(1, 2).Resize(UBound(results, 1), 1) = Application.Transpose(results)
End With
End Sub
I have an issue with understanding Excel VBA: Parsed JSON Object Loop.
I need a solution on the below code:
Sub getPricesOnReport()
Dim url As String: url = "http://statistics.mla.com.au/ReportApi/RunReport?ReportGuid=70587516-e17a-4065-a8aa-e3fe4c512159&FromDate=13%2F03%2F2017&ToDate=18%2F03%2F2017"
Dim httpRequest As Object: Set httpRequest = CreateObject("MSXML2.XMLHttp")
Dim httpResponse As Object
Dim scriptControl As Object: Set scriptControl = createObject("MSScriptControl.ScriptControl")
Dim XDOM As ListObject
scriptControl.Language = "JScript"
httpRequest.Open "GET", url, False
httpRequest.send
Set httpResponse = scriptControl.eval("(" + httpRequest.responseText + ")")
With Sheets("MLA")
If httpResponse.ResponseStatus <> "OK" Then
MsgBox "Error in Response"
Else
Cells(3, 2).Value = httpResponse.ResponseDate
Cells(3, 3).Value = httpResponse.ResponseHeader
Cells(3, 4).Value = httpResponse.ResponseStatus
Cells(3, 5).Value = httpResponse.ResponseDisclaimer
'Cells(4, 2).Value = httpResponse.returnValue '
End If
End With
End Sub
I am getting an error for the code
Cells(4, 2).Value = httpResponse.returnValue
though the object is available.
PFB image:
How do i modify the code to access the data?
In this case, Capitalization matters!
ReturnValue needs to be capitalized properly.
It may be defaulting to a "small r" when you type ReturnValue if there are other references to returnValue. (VBA is trying to be helpful by correcting the word to how you typed it before!)
In the VBA Editor:
hit Ctrl+H.
Enter ReturnValue for both Find What and Replace With.
Make sure Current Project is selected, and that Match Case is unchecked.
Click Replace All
Every occurrence of the word will be changed to the correct capitalization.
I am trying to write VBA to post json to an api and parse the results into a worksheet. I can generate the JSON and am confident I can parse the result into what I need.
I know there are online tools to convert json to vba and back and browser add ins to post requests but I am the only one in the office that can do this so if I'm sick or on leave I would like to automate it. To do that I need to send the json and maybe store the response so I can parse it.
I'm new to coding so posting a request like this is over my head.
So far I have the following code to write the json. I would appreciate any help in getting me started. If needed I can post a sample of the json or the api I would like to post it to.
Apologies for the poor code I know I can improve it but want to get the json response as I think it will be the most challenging part.
EDIT Have made some progress. Can now send a JSON string to the URL and get the response. However it is always returning a failure:
"{
""message"": ""An error has occurred.""
}"
If I manually send the json with httpRequestor the result is returned correctly.
This seems to suggest that somewhere in the code the JSON is getting mixed up or modified somehow when it is being posted.
Updated code below. (Have removed any reference to actual data)
EDIT 2 fixed and working.
Removed quotes from
objHTTP.send ("Json")
Private Sub CommandButton21_Click()
Dim h_1 As String
Dim h_2 As String
h_1 = Range("A1")
h_2 = Range("B1")
h_3 = Range("C1")
h_4 = Range("D1")
h_5 = Range("E1")
h_6 = Range("F1")
sv_1 = 2
sv_2 = 2
sv_3 = 2
sv_4 = 2
sv_5 = 2
sv_6 = 2
For f = 15 To 21
v_1 = Range("A" & sv_1)
v_2 = Range("B" & sv_2)
v_3 = Range("C" & sv_3)
v_4 = Range("D" & sv_4)
v_5 = Range("E" & sv_5)
v_6 = Range("F" & sv_6)
y = "[{""" & h_1 & """:""" & v_1 & """,""" & h_2 & """:""" & v_2 & """,""" & h_3 & """:""" & v_3 & """,""" & h_4 & """:""" & v_4 & """,""" & h_5 & """:""" & v_5 & """,""" & h_6 & """:""" & v_6 & """ }]"
Range("A" & f).Value = y
sv_1 = sv_1 + 1
sv_2 = sv_2 + 1
sv_3 = sv_3 + 1
sv_4 = sv_4 + 1
sv_5 = sv_5 + 1
sv_6 = sv_6 + 1
Next f
Dim objHTTP As Object
Dim Json As String
Json = Range("A15")
Dim result As String
'Set objIE = CreateObject("InternetExplorer.Application") ' Don't think this is needed
'objIE.navigate "about:blank" ' Don't think this is needed
'objIE.Visible = False ' Don't think this is needed
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
URl = "http://myApi/iSendJsonTo"
objHTTP.Open "POST", URl, False
'objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.setRequestHeader "Content-type", "application/json"
objHTTP.send ("Json")
result = objHTTP.responseText
'objIE.document.Write result ' Don't think this is needed
'Some simple debugging
Range("A25").Value = result
Range("A26").Value = Json
Set objHTTP = Nothing
Here is the code that is sending the JSON, cleaned up a little.
Dim objHTTP As Object
Dim Json As String
Json = Range("A15") 'here I am pulling in an existing json string to test it. String is created in other VBA code
Dim result As String
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
URl = "http://myApi/iSendJsonto/"
objHTTP.Open "POST", URl, False
objHTTP.setRequestHeader "Content-type", "application/json"
objHTTP.send (Json)
result = objHTTP.responseText
'Some simple debugging
Range("A25").Value = result
Range("A26").Value = Json
Set objHTTP = Nothing
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