This little snippet will allow you to calculate distance in ‚km‘ from 2 adresses.
I know it’s not that pretty but pretty functional.
Copyright @schindler-it.org
If this code was usefull make a reference in your code to me 🙂
You need to replace YOUR_KEY with your Bing Maps api key.
If you wish to have your result in miles rather than using km replace that string.
(Use distanceUnit=miles).
As I got some requests for the code, I added a proper German output of the values
that exchanges „,“ with „.“ and the other way around.
For further changes of the request itself please check the microsoft support page.
Public Function GetDistance(start As String, dest As String)
'From schindler-it.org - please don't delete this reference :)
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
objHTTP.Open "GET", "http://dev.virtualearth.net/REST/v1/Locations?q=" & start & "&key=YOUR_KEY", False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.send ("")
If InStr(objHTTP.responseText, "coordinates") = 0 Then GoTo ErrorHandl
Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = "(?=.*)\[([0-9]+.[0-9]+,[0-9]+.[0-9]+)\]": regex.Global = False
Set matches = regex.Execute(objHTTP.responseText)
coordinates1 = matches(0).SubMatches(0)
'MsgBox coordinates1
objHTTP.Open "GET", "http://dev.virtualearth.net/REST/v1/Locations?q=" & dest & "&key=YOUR_KEY", False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.send ("")
If InStr(objHTTP.responseText, "coordinates") = 0 Then GoTo ErrorHandl
Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = "(?=.*)\[([0-9]+.[0-9]+,[0-9]+.[0-9]+)\]": regex.Global = False
Set matches = regex.Execute(objHTTP.responseText)
coordinates2 = matches(0).SubMatches(0)
'MsgBox coordinates2
objHTTP.Open "GET", "https://dev.virtualearth.net/REST/v1/Routes/DistanceMatrix?origins=" & coordinates1 & "&destinations=" & coordinates2 & "&travelMode=driving&distanceUnit=km&output=json&key=YOUR_KEY", False
'Sheets(1).Cells(1, 1).Value = "https://dev.virtualearth.net/REST/v1/Routes/DistanceMatrix?origins=" & coordinates1 & "&destinations=" & coordinates2 & "&travelMode=driving&distanceUnit=km&output=json&key=YOUR_KEY"
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.send ("")
If InStr(objHTTP.responseText, "travelDistance") = 0 Then GoTo ErrorHandl
Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = "([0-9]+\.[0-9]+)": regex.Global = True
Set matches = regex.Execute(objHTTP.responseText)
msg = ""
For Each t In matches
msg = msg & t & vbCrLf
Next
'MsgBox msg
GetDistance = matches(4) 'english output
'GetDistance = Replace(Replace(matches(4), ",", ""), ".", ",") german output
Exit Function
ErrorHandl:
MsgBox "ERROR"
MsgBox (objHTTP.responseText)
GetDistance = -1
End Function