基于VBA的Excel与谷歌地图对接：添加途经点功能修改问询

当然可以修改这段代码来支持途经点功能！我帮你调整了代码，不仅添加了途经点参数，还修复了有途经点时距离和时间计算不准确的问题（因为Google会把行程拆分成多个路段，原来的代码只取了第一段）。下面是修改后的完整代码：

' Usage : 
' GetGoogleTravelTime (strFrom, strTo, [strWaypoints]) returns a string containing journey duration : hh:mm 
' GetGoogleDistance (strFrom, strTo, [strWaypoints]) returns a string containing journey distance in either miles or km (as defined by strUnits) 
' GetGoogleDirections (strFrom, strTo, [strWaypoints]) returns a string containing the directions 
' 
' where strFrom/To are address search terms recognisable by Google 
' strWaypoints is optional: single waypoint or multiple waypoints separated by | 
' i.e. Postcode, address etc. 
' 
' by Desmond Oshiwambo, modified to support waypoints
Const strUnits = "metric" ' imperial/metric (miles/km) 

Function CleanHTML(ByVal strHTML) 
'Helper function to clean HTML instructions 
Dim strInstrArr1() As String 
Dim strInstrArr2() As String 
Dim s As Integer 
strInstrArr1 = Split(strHTML, "<") 
For s = LBound(strInstrArr1) To UBound(strInstrArr1) 
    strInstrArr2 = Split(strInstrArr1(s), ">") 
    If UBound(strInstrArr2) > 0 Then 
        strInstrArr1(s) = strInstrArr2(1) 
    Else 
        strInstrArr1(s) = strInstrArr2(0) 
    End If 
Next 
CleanHTML = Join(strInstrArr1) 
End Function 

Public Function formatGoogleTime(ByVal lngSeconds As Double) 
'Helper function. Google returns the time in seconds, so this converts it into time format hh:mm 
Dim lngMinutes As Long 
Dim lngHours As Long 
lngMinutes = Fix(lngSeconds / 60) 
lngHours = Fix(lngMinutes / 60) 
lngMinutes = lngMinutes - (lngHours * 60) 
formatGoogleTime = Format(lngHours, "00") & ":" & Format(lngMinutes, "00") 
End Function 

Function gglDirectionsResponse(ByVal strStartLocation, ByVal strEndLocation, Optional ByVal strWaypoints As String = "", ByRef strTravelTime, ByRef strDistance, ByRef strInstructions, Optional ByRef strError = "") As Boolean 
On Error GoTo errorHandler 
' Helper function to request and process XML generated by Google Maps. 
Dim strURL As String 
Dim objXMLHttp As Object 
Dim objDOMDocument As Object 
Dim nodeRoute As Object 
Dim nodeLeg As Object 
Dim lngTotalDistance As Long 
Dim lngTotalSeconds As Double 

Set objXMLHttp = CreateObject("MSXML2.XMLHTTP") 
Set objDOMDocument = CreateObject("MSXML2.DOMDocument.6.0") 

' Format locations for URL
strStartLocation = Replace(strStartLocation, " ", "+") 
strEndLocation = Replace(strEndLocation, " ", "+") 
strWaypoints = Replace(strWaypoints, " ", "+")
strWaypoints = Replace(strWaypoints, "|", "%7C") ' Encode | for URL

' Build request URL
strURL = "http://maps.googleapis.com/maps/api/directions/xml" & _ 
    "?origin=" & strStartLocation & _ 
    "&destination=" & strEndLocation & _ 
    "&sensor=false" & _ 
    "&units=" & strUnits 

' Add waypoints parameter if provided
If strWaypoints <> "" Then
    strURL = strURL & "&waypoints=" & strWaypoints
End If

'Sensor field is required by google and indicates whether a Geo-sensor is being used by the device making the request 
'Send XML request 
With objXMLHttp 
    .Open "GET", strURL, False 
    .setRequestHeader "Content-Type", "application/x-www-form-URLEncoded" 
    .Send 
    objDOMDocument.LoadXML .ResponseText 
End With 

With objDOMDocument 
    If .SelectSingleNode("//status").Text = "OK" Then 
        ' Initialize total distance and time
        lngTotalDistance = 0
        lngTotalSeconds = 0
        
        ' Iterate through all legs to calculate total distance and time
        For Each nodeLeg In .SelectNodes("/DirectionsResponse/route/leg")
            ' Accumulate distance (in meters)
            lngTotalDistance = lngTotalDistance + nodeLeg.SelectSingleNode("distance/value").Text
            ' Accumulate time (in seconds)
            lngTotalSeconds = lngTotalSeconds + nodeLeg.SelectSingleNode("duration/value").Text
            
            ' Get directions for each leg's steps
            For Each nodeRoute In nodeLeg.ChildNodes 
                If nodeRoute.BaseName = "step" Then 
                    strInstructions = strInstructions & nodeRoute.SelectSingleNode("html_instructions").Text & " - " & nodeRoute.SelectSingleNode("distance/text").Text & vbCrLf 
                End If 
            Next
        Next
        
        ' Convert total distance to desired units
        Select Case strUnits 
            Case "imperial": strDistance = Round(lngTotalDistance * 0.00062137, 1) ' Meters to miles
            Case "metric": strDistance = Round(lngTotalDistance / 1000, 1) ' Meters to kilometers
        End Select 
        
        ' Convert total time to hh:mm format
        strTravelTime = formatGoogleTime(lngTotalSeconds) 
        
        ' Clean up directions text
        strInstructions = CleanHTML(strInstructions) 
    Else 
        strError = .SelectSingleNode("//status").Text 
        GoTo errorHandler 
    End If 
End With 

gglDirectionsResponse = True 
GoTo CleanExit 

errorHandler: 
If strError = "" Then 
    strError = Err.Description 
    strDistance = -1 
    strTravelTime = "00:00" 
    strInstructions = "" 
End If 
gglDirectionsResponse = False 

CleanExit: 
Set objDOMDocument = Nothing 
Set objXMLHttp = Nothing 
End Function 

Function getGoogleTravelTime(ByVal strFrom, ByVal strTo, Optional ByVal strWaypoints As String = "") As String 
'Returns the journey time between strFrom and strTo (with optional waypoints) 
Dim strTravelTime As String 
Dim strDistance As String 
Dim strInstructions As String 
Dim strError As String 

If gglDirectionsResponse(strFrom, strTo, strWaypoints, strTravelTime, strDistance, strInstructions, strError) Then 
    getGoogleTravelTime = strTravelTime 
Else 
    getGoogleTravelTime = strError 
End If 
End Function 

Function getGoogleDistance(ByVal strFrom, ByVal strTo, Optional ByVal strWaypoints As String = "") As String 
'Returns the distance between strFrom and strTo (with optional waypoints) 
'where strFrom/To are address search terms recognisable by Google 
'i.e. Postcode, address etc. 
Dim strTravelTime As String 
Dim strDistance As String 
Dim strError As String 
Dim strInstructions As String 

If gglDirectionsResponse(strFrom, strTo, strWaypoints, strTravelTime, strDistance, strInstructions, strError) Then 
    getGoogleDistance = strDistance 
Else 
    getGoogleDistance = strError 
End If 
End Function 

Function getGoogleDirections(ByVal strFrom, ByVal strTo, Optional ByVal strWaypoints As String = "") As String 
'Returns the directions between strFrom and strTo (with optional waypoints) 
'where strFrom/To are address search terms recognisable by Google 
'i.e. Postcode, address etc. 
Dim strTravelTime As String 
Dim strDistance As String 
Dim strError As String 
Dim strInstructions As String 

If gglDirectionsResponse(strFrom, strTo, strWaypoints, strTravelTime, strDistance, strInstructions, strError) Then 
    getGoogleDirections = strInstructions 
Else 
    getGoogleDirections = strError 
End If 
End Function

关键修改说明 #

• 新增途经点参数：给所有对外函数和核心处理函数都添加了可选的strWaypoints参数，支持单个或多个途经点（多个途经点用|分隔，比如"北京|上海"）；
• URL参数处理：对途经点字符串进行URL编码，把空格替换为+，把|替换为URL编码后的%7C，符合Google API的要求；
• 总行程计算修复：原来的代码只读取第一个路段（leg）的距离和时间，现在改为遍历所有路段并累加，确保有途经点时返回的是完整行程的总距离和总时间；
• 导航路线整合：把所有路段的导航步骤整合到一起，返回完整的途经点导航说明。

使用方法 #

在Excel单元格中直接调用即可：

• 计算带单个途经点的行程时间：=getGoogleTravelTime(A1, B1, C1)（A1=起点，B1=终点，C1=途经点）
• 计算带多个途经点的行程距离：=getGoogleDistance(A1, B1, "C1|D1")（或者直接在第三个参数里输入多个用|分隔的地址）
• 获取完整导航路线：=getGoogleDirections(A1, B1, C1)

如果不需要途经点，直接保留原有调用方式（比如=getGoogleTravelTime(A1,B1)）即可，完全兼容原有功能。

内容的提问来源于stack exchange，提问作者Przemek