Google Maps API を使って2点間の距離を求めるユーザー定義関数を作る

最終更新: 7日前


上の図のC列には出発地、D列には目的地、E列には下の式が入っています。


=DGMAP ([origin], [destination], TRUE: distance/  FALSE: time)

このユーザー定義関数は距離と時間の両方を返すことができますが、第3引数にTRUEを入れると距離が、FALSEを入れると時間を返すように変更しています。この関数で利用しているGoogle Maps APIがいつまで利用可能か分かりませんが、2018年1月19日現在、問題なく利用できています。

コードのほとんどは、ここ から拝借しました。 Microsoft XML v.[version]を参照設定して、次のコードを標準モジュール内に貼り付けて下さい。

(修正 2019/10/22)

Google Direction APIは、残念ながらAPIキーなしでの利用ができなくなっているようです。 APIキーを取得して、コードに追加して下さい。

"sXMLURL = ..." でhttpを https に変更。APIキーを追加)


Function DGMAP(origin As String, destination As String, distance As Boolean) As String

    'http://stackoverflow.com/questions/10116301/google-maps-api-for-time-and-distance-data-access-vba
 

    Dim sXMLURL As String
 sXMLURL = "https://maps.googleapis.com/maps/api/directions/xml?origin=" & origin & "&destination=" & destination & "&sensor=false&key=APIキー"
 

    Dim objXMLHTTP As MSXML2.ServerXMLHTTP60

    Set objXMLHTTP = New MSXML2.ServerXMLHTTP60
 

    With objXMLHTTP

        .Open "GET", sXMLURL, False

        .setRequestHeader "Content-Type", "application/x-www-form-URLEncoded"

        .Send

    End With
 

    'Debug.Print objXMLHTTP.ResponseText
 

    Dim domResponse As DOMDocument60

    Set domResponse = New DOMDocument60

    domResponse.LoadXML objXMLHTTP.ResponseText

    Dim ixnStatus

    Set ixnStatus = domResponse.SelectSingleNode("//status")
 

    If ixnStatus.Text = "OK" Then

        Dim ixnDistance, ixnDuration

        Set ixnDistance = domResponse.SelectSingleNode("/DirectionsResponse/route/leg/distance/text")

        Set ixnDuration = domResponse.SelectSingleNode("/DirectionsResponse/route/leg/duration/text")

    End If

    If IsEmpty(ixnDistance) Then

        DGMAP = "Empty"

        Exit Function

    End If
 '距離(True) または時間(False)

    If distance = True Then

        DGMAP = left(ixnDistance.Text, InStr(1, ixnDistance.Text, " ") - 1)

    Else

        DGMAP = ixnDuration.Text

    End If

    Set domResponse = Nothing

    Set objXMLHTTP = Nothing

End Function

#ExcelVBA #GoogleMaps