I am using the following code in Excel to calculate the travel distance between various places. In this calculation it calculates the "driving" directions.
I am however also looking for the public transport directions. I've been puzzling how to change the code to change the travel mode (https://developers.google.com/maps/documentation/directions/overview#TravelModes), but I cant get it to work. Does anybody have an idea how to incorporate this?
Function TRAVELTIME(origin, destination, apikey)
Dim strUrl As String
strUrl = "https://maps.googleapis.com/maps/api/directions/json?origin=" & origin & "&destination=" & destination & "&key=" & apikey
Set httpReq = CreateObject("MSXML2.XMLHTTP")
With httpReq
.Open "GET", strUrl, False
.Send
End With
Dim response As String
response = httpReq.ResponseText
Dim parsed As Dictionary
Set parsed = JsonConverter.ParseJson(response)
Dim seconds As Integer
Dim leg As Dictionary
For Each leg In parsed("routes")(1)("legs")
seconds = seconds + leg("duration")("value")
Next leg
TRAVELTIME = seconds
Related
I have a function in excel to extract travel distance using Google Maps API that looks like this: Function TRAVELDISTANCE(origin, destination, apikey)
Dim strUrl As String
strUrl = "https://maps.googleapis.com/maps/api/directions/json?origin=" & origin & "&destination=" & destination & "&key=" & apikey
Set httpReq = CreateObject("MSXML2.XMLHTTP")
With httpReq
.Open "GET", strUrl, False
.Send
End With
Dim response As String
response = httpReq.ResponseText
Dim parsed As Dictionary
Set parsed = JsonConverter.ParseJson(response)
Dim KM As Long
Dim leg As Dictionary
For Each leg In parsed("routes")(1)("legs")
meters = meters + leg("distance")("value")
Next leg
TRAVELDISTANCE = meters
End Function
Does anyone know how I can edit this to give me the value "Ferry" if the route includes a ferry?
Maybe this.
https://www.google.com/maps/dir/50.8971936,-1.397307/50.8653945,-1.3991824/#50.8705321,-1.4018442,16z/am=t/data=!4m6!4m5!3e2!6m3!1i0!2i0!3i7
F2 to see the code behind the page.
I'm very new to API coding but I have created an API Code that inputs pressure and outputs temperature for a specific refrigerant on a website. However, I can only call for one refrigerant at a time, I was wondering if it is possible to create a string with all the refrigerant id (refId) numbers, so the API code could run through all of them in one long run?
Option Explicit
Public Function GetPressureFromTemp(ByVal Temperature As Double) As Double
Dim body As String
body = "{""Temperature"":""" & Temperature & """,""refId"":""r13"",""temperatureUnit"":""fahrenheit"",""pressureUnit"":""psi"","
body = body & """pressureReferencePoint"":""gauge"","
body = body & """pressureCalculationPoint"":""bubble"",""gaugeType"":""dry"",""altitudeInMeter"":0}"
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", "https://reftools.danfoss.com/api/ref-slider/Pressure?refId=r13", False
.setRequestHeader "content-type", "application/json; charset=utf-8"
.send body
GetPressureFromTemp = CDbl(.responseText)
End With
End Function
Public Sub test()
Dim n As Double
Dim a As Double
a = 4984
n = -150.8
Do Until n >= 74.93
n = n + 0.1
'Debug.Print GetPressureFromTemp(n)
Range("J" & a) = GetPressureFromTemp(n)
a = a + 1
Loop
End Sub
I'm not sure how to loop through each ref ID, however I have the whole list containing the refrigerant id
To make sure an address is always formatted the same way (which I will use in another VBA Sub), I'm trying to use the Google Places API in combination with a created VBA function.
The query works in the browser but not from the created function.
The working API (temporary API-key added) with a random address: https://maps.googleapis.com/maps/api/place/findplacefromtext/json?fields=formatted_address%2Cname%2Crating%2Copening_hours%2Cgeometry&input=Coendersweg%202&inputtype=textquery&key=API_KEY
It gives "Formatted_Address" which I'd like to show up as the result of the function.
Example result of random address:
Coendersweg 2, 9722GE Groningen / [Streetname number, Zipcode City]
If it's possible to make resulting address have the zip code (9722 GE) formatted as "9722GE" and the country ", Nederland" not show up that would be even better.
VBA code I have so far:
Function FindAddress(address, APIKEY)
Dim strURL As String
strURL = "https://maps.googleapis.com/maps/api/place/findplacefromtext/" & _
"json?fields=formatted_address%2Cname%2Crating%2Copening_hours%2Cgeometry&input=" _
& address & "&inputtype=textquery&key=" & APIKEY
Set httpReq = CreateObject("MSXML2.XMLHTTP")
With httpReq
.Open "GET", strURL, False
.Send
End With
Dim Response As String
Response = httpReq.ResponseText
Dim parsed As Dictionary
Set parsed = JsonConverter.ParseJson(Response)
Dim FoundAddress As String
FoundAddress = (formatted_address)
FindAddress = FoundAddress
I've the "JsonConverter.bas" from https://github.com/VBA-tools/VBA-JSON as a module inside my VBA.
Most of the code is borrowed from the following YouTube video. I made some tweaks to work with Google Places API instead of Google Directions API:
https://www.youtube.com/watch?v=_P2lj4yHNu4.
Here's a method that will return the formatted_address field. You can return other fields if you prefer -- the modifications should be obvious.
Note that I used early binding, but you can use late binding if you prefer.
Run against your input, => Coendersweg 2, 9722 GE Groningen, Netherlands
Option Explicit
Function getAddress(S As String)
Const API As String = "key=YOUR_API_KEY"
Const sURL1 As String = "https://maps.googleapis.com/maps/api/place/findplacefromtext/json?fields=formatted_address"
Const sURL2 As String = "input="
Const sURL3 As String = "inputtype=textquery"
Dim sAddr As String
Dim sURL() As String
Dim sLocation As String
Dim xhrRequest As XMLHTTP60
Dim strJSON As String, JSON As Object
sAddr = Replace(S, " ", "%20")
'Many ways to create the URL to send
ReDim sURL(3)
sURL(0) = sURL1
sURL(1) = sURL2 & sAddr
sURL(2) = sURL3
sURL(3) = API
Set xhrRequest = New XMLHTTP60
With xhrRequest
.Open "Get", Join(sURL, "&"), False
.Send
strJSON = .ResponseText
End With
Set JSON = ParseJson(strJSON)
If Not JSON("status") = "OK" Then
MsgBox "Status message: " & JSON("status")
Exit Function
End If
'might need to check if more than one candidate is returned
getAddress = JSON("candidates")(1)("formatted_address")
End Function
If you want to have the format different from what is shown, I suggest you use the Places api to return the place_id. You can then feed that value into the Place Details to return the address_components and format the address however you prefer.
I'm trying to develop a function in excel that returns the traveltime between two locations. I used this code i found online, yet always get a #value error. When I plug in the strUrl in my browser with my apikey the request works.
Help is very much appreciated.
' Returns the number of seconds it would take to get from one place to another
Function TRAVELTIME(origin, destination, apikey)
Dim strUrl As String
strUrl = "https://maps.googleapis.com/maps/api/distancematrix/json?units=imperial&origins=" & origin & "&destinations=" & destination & "&key=" & apikey
Set httpReq = CreateObject("MSXML2.XMLHTTP")
With httpReq
.Open "GET", strUrl, False
.Send
End With
Dim response As String
response = httpReq.ResponseText
Dim parsed As Dictionary
Set parsed = JsonConverter.ParseJson(response)
Dim seconds As Integer
Dim leg As Dictionary
For Each leg In parsed("routes")(1)("legs")
seconds = seconds + leg("duration")("value")
Next leg
TRAVELTIME = seconds
End Function
The JSON structure is different than what your code is expecting. (Examine the Google documentation for the distance-matrix api to determine that.)
You need something like:
Set parsed = JsonConverter.ParseJson(response)
Dim seconds As Integer
Dim leg As Dictionary
For Each leg In parsed("rows")(1)("elements")
seconds = seconds + leg("duration")("value")
Next leg
TRAVELTIME = seconds
Note: You have declared seconds as Integer. If you examine the VBA data types, you will note that Integer has a maximum value of 32,767 which is a bit more than nine (9) hours. If the sum of your durations might be longer than this, and you do not wish to have an Overflow error, suggest you declare seconds as Long or Double.
For a university research project, I plan to run a larger number of data requests with a total of c. 3,000 different spreadsheets, each including about 800-1,000 unique data requests.
Aim of the code is to get the number of Google News results for certain search terms within specific time frames, as for instance the results for "Elon Musk" between 01/01/2015 and 12/31/2015.
I have so far constructed a code that works relatively well with a single-threaded approach but would, given the large number of data requests, take weeks for the 3,000 spreadsheets to be completed (Google is occasionally blocking the requests given the sheer number of search queries but this is something generally manageable).
On the other hand, I have read that there is not "native" option in VBA to go for a time saving multi-threading approach, while several suggestions exist to work around this lack of a real multi-threading function. None of them has however really worked for my case so far.
Is there any practicable option to have the code below send out several Google requests at a time? This would allow the data collection in a much shorter time span. As mentioned, I have already been through a number of complex "out of the box" multi-threading solutions, of which none really worked.
Option Explicit
Sub TermCheck()
Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
Dim start_time As Date
Dim end_time As Date
Dim var As String
Dim var1 As Object
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim cookie As String
Dim result_cookie As String
start_time = Time
Debug.Print "start_time:" & start_time
For i = 62 To lastRow
url = "https://www.google.com/search?q=" & Cells(i, 3) & "&source=lnt&tbs=cdr%3A1%2Ccd_min%3A" & Cells(i, 4) & "%2Ccd_max%3A" & Cells(i, 5) & "&tbm=nws"
Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
XMLHTTP.Open "GET", url, False
XMLHTTP.setRequestHeader "Content-Type", "text/xml"
XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
XMLHTTP.send
Set html = CreateObject("htmlfile")
html.body.innerHTML = XMLHTTP.responseText
Set objResultDiv = html.getElementById("rso")
Set var1 = html.getElementById("resultStats")
If Not var1 Is Nothing Then
Cells(i, 6).Value = var1.innerText
End If
DoEvents
Next
end_time = Time
Debug.Print "end_time:" & end_time
Debug.Print "done" & "Time taken : " & DateDiff("n", start_time, end_time)
MsgBox "done" & "Time taken : " & DateDiff("n", start_time, end_time)
End Sub
I think you are on the right track by consolidating your data upfront, this is often a good idea for most projects. I'm not so sure you should give up on Async requests so quickly, have a go at this code below and see if that helps speed up your project.
I assumed that dates where in Columns D and E, so I mocked up my data to this idea. I also hard coded 'Elon Musk' in there to make things easier testing. You probably need to change this.
Option Explicit
Sub TermCheck(RunAsync As Boolean)
Const READYSTATE_COMPLETE As Long = 4
Dim url As String
Dim WebRequest As Object
Dim WebRequests As Object
Dim CellIndex As Variant
Dim Document As Object
Dim ResultStat As Object
Dim ws As Worksheet
Dim StartDate As Date
Dim EndDate As Date
Dim i As Long
StartDate = #1/1/2015#
EndDate = #1/2/2015#
Set ws = ThisWorkbook.Worksheets("Sheet3")
Set WebRequests = CreateObject("Scripting.Dictionary")
For i = 1 To 30
'Change URL here
url = "https://www.google.com/search?q=Elon%20Musk" & _
"&source=lnt&tbs=cdr%3A1%2Ccd_min%3A" & Replace(Format(ws.Cells(i, 4), "m/d/yyyy"), "/", "%2F") & _
"%2Ccd_max%3A" & Replace(Format(ws.Cells(i, 5), "m/d/yyyy"), "/", "%2F") & "&tbm=nws"
Set WebRequest = CreateObject("MSXML2.XMLHTTP")
With WebRequest
.Open "GET", url, RunAsync
.setRequestHeader "Content-Type", "text/xml"
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
.send
End With
StartDate = DateAdd("d", 1, StartDate)
EndDate = DateAdd("d", 1, EndDate)
WebRequests.Add i, WebRequest
Next
For Each CellIndex In WebRequests.Keys
Set WebRequest = WebRequests(CellIndex)
While WebRequest.Readystate <> READYSTATE_COMPLETE: DoEvents: Wend
If WebRequest.Status = 200 Then
Set Document = CreateObject("htmlfile")
Document.body.innerhtml = WebRequest.ResponseText
Set ResultStat = Document.getElementById("resultStats")
'Missing equals sign was here
If Not ResultStat Is Nothing Then ws.Cells(CellIndex, 6).Value2 = ResultStat.innertext
End If
Next
End Sub
Sub TestRunRequests()
'Run it Synchronous
Application.ScreenUpdating = False
Dim MyTimer As Double
MyTimer = Timer
TermCheck False
Debug.Print "Synchronous took: " & Timer - MyTimer
'Run it Asynchronous
MyTimer = Timer
TermCheck True
Debug.Print "Asynchronous took: " & Timer - MyTimer
Application.ScreenUpdating = True
End Sub
Here are my the timings (in seconds) I got when I did 100 Requests for each method (async and sync):
Synchronous took: 44.5625
Asynchronous took: 22.46875
This may rather be the "pedestrian way" regarding a time saving approach but I decided to paste all relevant spreadsheets into one major Excel file. When amending the code to cover all spreadsheets simultaneously (and not only the active one), the search processes can literally be conducted in a fraction of the time otherwise required.