Solved: Total distance and time between two cities in a state

[JP2112]

All of the driving directions APIs I've found so far require street addresses, and don't take lat/lon pairs. I'd be super happy to hear otherwise.

By the way MapQuest also has a driving directions API, and their TOS (unlike Google's) doesn't require you to display a map:

http://www.mapquestapi.com/directions/

[Morglam]

OK, I'll check that out, thanks a lot.

[Shred Dude]

Here you go...

Attached workbook contains new Class Module to encapsulate functionality.

Two public Functions in a Module expose methods of the class:

distCoords, and distAddresses

Use as formulas from Module:

=getAddressDistance(...
=getCoordDistance(stCoords As String, EndCoords As String)

[Morglam]

Wow man...it works perfectly...don't know how to thank you...

The least I could do is put you on the acknowledgment section of the article I'm (hopefully) to publish. I you feel like it don't hesitate to give me your full name and institution of reference.

Thank you again!

Regards,

[vishwakarma]

Hi Guys,

Can you please help in the code below it is showing me kind of weird error, it was working perfectly untill yesterday but when I tried it today, it is showing me error of every records.

[vba]

Public Function getGoogDistanceTime(startAddr As String, startCity As String, _
startState As String, startZip As String, endAddr As String, _
endCity As String, endState As String, endZip As String) As String

Dim sURL As String
Dim BodyTxt As String

sURL = "http://maps.google.com/maps?f=d&source=s_d&saddr="
sURL = sURL & Replace(startAddr, " ", "+") & ",+" & Replace(startCity, " ", "+") & ",+" & startState
sURL = sURL & "&daddr=" & Replace(endAddr, " ", "+") & ",+" & Replace(endCity, " ", "+") & ",+" & endState
sURL = sURL & "&hl=en"

BodyTxt = getHTML(sURL)

If InStr(1, BodyTxt, "distance:""") = 0 Then getGoogDistanceTime = "Error": Exit Function

getGoogDistanceTime = parseGoog("distance", BodyTxt) & " / " & parseGoog("time", BodyTxt)

End Function

Public Function getHTML(strURL As String) As String
'Returns the HTML code underlying a given URL
Dim oXH As Object
Set oXH = CreateObject("msxml2.xmlhttp")
With oXH
.Open "get", strURL, False
.send
getHTML = .responseText
End With
Set oXH = Nothing
End Function

Public Function parseGoog(strSearch As String, strHTML As String) As String
strSearch = strSearch & ":"""
If InStr(1, strHTML, strSearch) = 0 Then parseGoog = "Not Found": Exit Function
parseGoog = Mid(strHTML, InStr(1, strHTML, strSearch) + Len(strSearch))
parseGoog = Mid(parseGoog, 1, InStr(1, parseGoog, """") - 1)
End Function

[/vba]

Please help me... I tried to work on it but not able to find the issue...

[Kenneth Hobs]

When parsing HTML source code, if your code relies on that code being consistent and that code does change, things go amiss. Looking at the source code, the first change that you might notice is that some double quotes were replaced by single quotes. I have not tried but try:

[VBA]Private Function parseGoog(strSearch As String, strHTML As String) As String
strSearch = strSearch & ":'"
If InStr(1, strHTML, strSearch) = 0 Then parseGoog = "Not Found": Exit Function
parseGoog = Mid(strHTML, InStr(1, strHTML, strSearch) + Len(strSearch))
parseGoog = Mid(parseGoog, 1, InStr(1, parseGoog, "'") - 1)
End Function[/VBA]

[vishwakarma]

Hi Kenneth,

Thanks for the suggestion. I tried it but it is still not working and giving me the error plus now the file is hanging and not responding as well.

I'm attaching the file if in case you might want to test it.

Looking forward for your reply.


Thanks

[Kenneth Hobs]

There were too many problems with the one that you posted. I also changed to the WinHttp object and used the previous code modified with the single quote replacements. If the application is volatile then for every recalculation, other functions recalculates so if you have a problem, it is fairly circular and locks Excel. Ctrl+Break and ESC can help and even Application.Calculation=xlCalculationManual in the Immediate window will not stop the code from executing again.

[VBA]Public Function getGoogDistanceTime(startAddr As String, StartCity As String, _
startState As String, StartZip As String, endAddr As String, _
EndCity As String, endState As String, EndZip As String) As String

Dim sURL As String
Dim HTTPreq As Object
Dim BodyTxt As String
Dim s As String, _
d As String, _
t As String

Application.Volatile False

sURL = "http://maps.google.com/maps?f=d&source=s_d&saddr="
sURL = sURL & Replace(startAddr, " ", "+") & ",+" & Replace(StartCity, " ", "+") & ",+" & startState
sURL = sURL & "&daddr=" & Replace(endAddr, " ", "+") & ",+" & Replace(EndCity, " ", "+") & ",+" & endState
sURL = sURL & "&hl=en"

'Set HTTPreq = CreateObject("msxml2.xmlhttp")
Set HTTPreq = CreateObject("WinHttp.WinHttpRequest.5.1")
With HTTPreq
.Open "GET", sURL, False
.send
.WaitForResponse
BodyTxt = .responseText
End With
Set HTTPreq = Nothing

s = "distance:'"

If InStr(1, BodyTxt, s) = 0 Then getGoogDistanceTime = "Error": Exit Function

d = Mid(BodyTxt, InStr(1, BodyTxt, s) + Len(s))
d = Mid(d, 1, InStr(1, d, "'") - 1)

s = "time:'"
t = Mid(BodyTxt, InStr(1, BodyTxt, s) + Len(s))
t = Mid(t, 1, InStr(1, t, "'") - 1)

getGoogDistanceTime = d & " / " & t

End Function

[/VBA]

See cell I3 and Module 3 for the UDF. I have not worked on the others much to see what they need.

[vishwakarma]

Thanks a lot Kenneth...for your valuable help and suggestion...

[Morglam]

Sorry to bother, but the formula Shred Dude gave me seems to be no longer working. It doesn't return me any result. There has been any change in Google API or it's me?

I attach you the same file that was working like magic until some days ago. If anyone can help me out will save my life.

Thanks in advance.

[vishwakarma]

Hi,

Just try the code provided by Mr. Kenneth....

I've attached the sheet provided by him.

[Morglam]

Hi,

Thanks for the tip but the thing is that I need a formula that works with coordinates. Mr. Kenneth formula seems to work ok but it just works with addresses. I really don't get why the formula on the sheet I attached stopped working...

Please, any help will be welcomed.

Regards,

[vishwakarma]

please send the attachment..

[Morglam]

It's attached on my last post.

Regards,

[vishwakarma]

see if this works for you...

[Morglam]

Yeah, works fine! What was the matter then?

Thanks a lot.

Regards,

[vishwakarma]

When parsing HTML source code, if your code relies on that code being consistent and that code does change, things go amiss. Looking at the source code, the first change that you might notice is that some double quotes were replaced by single quotes. I have not tried but try:

VBA:

Private Function parseGoog(strSearch As String, strHTML As String) As String
strSearch = strSearch & ":'"
If InStr(1, strHTML, strSearch) = 0 Then parseGoog = "Not Found": Exit Function
parseGoog = Mid(strHTML, InStr(1, strHTML, strSearch) + Len(strSearch))
parseGoog = Mid(parseGoog, 1, InStr(1, parseGoog, "'") - 1)
End Function

[relima]

tks

[krishnak]

This looks to be a very elegant solution.

Somehow both variations (with Mapquest and Google) are not working on my Excel Application VBA window. I am getting "Error" in case of Google code and "Address Error, fix and try again" for Mapquest.

In both cases, the internet opens the website and displays the details of Driving directions with distance and time.

I have the following references in my VBA Editor:

Microsoft Excel 12.0 Object Library
Microsoft Internet Controls
Microsoft Office 12.0 Object Library
Microsoft Scripting Runtime
Microsoft HTML Object Library
Microsoft DAO 3.6 Object Library
Microsoft VBScript Regular Expressions 5.5

I am using Excel 2007.
What could be the problem?

[neverknow]

It was such a wonderful UDF, since about December, 14. Something changed and it no longer works. If you guys could be amazing again and fix it, I would really really appreciate it!