This is a modified version of code I have used elsewhere, it returns drive time in seconds, and distance in meters between 2 given postcodes. I've only tested this in the UK, but I don't see why it wouldn't work elsewhere.
It uses the same services that the on-line TomTom route planner uses. I've read through the T&Cs of the service and can't find anything that using the service in this way would breach, but let me know if you think there are issues and I'll remove the code. (I used to use google APIs for doing this, but it breaches their T&Cs so this is an alternative - there is also a Bing Maps method that I've used, but find this more reliable).
The only required parameters are the A-End and B-End Postcodes, without setting the other parameters, the function will assume the following:
- It should not route to avoid traffic
- It should not include traffic delays in drive time duration
- Day of travel is Today
- Time of travel is Now
'--------------------------------------------------------------------------
' Purpose: Retrieves DriveTime and Distance between 2 postcodes '
' Parameters: '
' Required: '
' aEnd - Postcode '
' bEnd - Postcode '
' Optional: '
' AvoidTraffic - Whether a route that avoids '
' traffic should be returned '
' IncludeTraffic - Include traffic in calculating '
' travel time '
' DayofWeek - Day of Week of travel '
' Time - Time of departure in minutes '
' From Midnight '
' Returns: Collection of '
' "Distance" in Meters '
' "Duration" in Seconds '
'--------------------------------------------------------------------------
Public Function GetTimeAndDistance(aEnd As String, _
bEnd As String, _
Optional avoidTraffic As Boolean, _
Optional includeTraffic As Boolean, _
Optional DayofWeek As VbDayOfWeek, _
Optional time As Long) As Collection
Dim aLong As String
Dim aLat As String
Dim bLong As String
Dim bLat As String
Dim url As String
Dim ret As Collection
Dim Days As Variant
Set ret = New Collection
Days = Array("today", "sunday", "monday", "tuesday", "wednesday", "thursday", "friday", "saturday")
With CreateObject("MSXML2.XMLHTTP")
'GeoCode aEnd
.Open "GET", "http://routes.tomtom.com/lbs/services/geocode/1/query/" & aEnd & "/json/1e2099c7-eea9-476b-aac9-b20dc7100af1;language=en;map=basic", False
.send
aLong = Split(Split(.responsetext, "longitude"":")(1), ",")(0)
aLat = Split(Split(.responsetext, "latitude"":")(1), ",")(0)
'GeoCode bEnd
.Open "GET", "http://routes.tomtom.com/lbs/services/geocode/1/query/" & bEnd & "/json/1e2099c7-eea9-476b-aac9-b20dc7100af1;language=en;map=basic", False
.send
bLong = Split(Split(.responsetext, "longitude"":")(1), ",")(0)
bLat = Split(Split(.responsetext, "latitude"":")(1), ",")(0)
'Get Route Info
.Open "GET", "http://routes.tomtom.com/lbs/services/route/1/" _
& aLat & "," & aLong & ":" & bLat & "," & bLong & _
"/Quickest/json/1e2099c7-eea9-476b-aac9-b20dc7100af1;language=en;" _
& "avoidTraffic=" & LCase(avoidTraffic) _
& ";includeTraffic=" & LCase(includeTraffic) _
& ";day=" & Days(DayofWeek) _
& ";time=" & IIf(time = 0, "now", time) _
& ";iqRoutes=2;trafficModelId=-1;map=basic", False
.send
ret.Add Val(Split(.responsetext, "totalDistanceMeters"":")(1)), "Distance"
ret.Add Val(Split(.responsetext, "totalTimeSeconds"":")(1)), "Time"
End With
Set GetTimeAndDistance = ret
End FunctionA sample usage:
Sub TestingDistance()Dim data As Collection
Set data = GetTimeAndDistance("SW1A 1AA", "LS15 0AD", True, True, vbFriday, 960)
Sheet1.Range("A1").Value = data("Distance") * 0.000621371192
With Sheet1.Range("A2")
.Value = data("Time") / 86400
.NumberFormat = "hh:mm:ss"
End With
End Sub
