VBAでGoogle Maps Platform / Routes APIを使うぞ！

VBAで使う人はいないんやろねぇ…
情報少なく、HTTPでPOSTするのに苦労したのでアップしときます。

参考にさせて頂いたページ：
http://piyopiyocs.blog115.fc2.com/blog-entry-433.html

Routes APIのガイドのページ：
https://developers.google.com/maps/documentation/routes/compute_route_directions?hl=ja

プロシージャ

Public Sub gMapAPI_FromTo(ByVal pointA As String, _
                          ByVal pointB As String, _
                          ByRef 距離 As String, _
                          ByRef 時間 As String, _
                          ByRef 判定 As String)
On Error GoTo Err
                          
    '[機能]----------------------------------------------------------------------------------------
    '   Routes APIを利用して、引数として受け取ったA地点(pointA)からB地点(pointB)までの、距離と時間を返す。
    '
    '   <引数/ByVal>
    '       pointA：    起点となる緯度経度　例) 34.5240673, 135.4807751
    '       pointB：    終点となる緯度経度　例) 34.4721319, 135.5727400
    '
    '   <引数/ByRef ⇒戻り値>
    '       距離：      単位はメートル      例)15460
    '       時間：      単位は秒            例)1737
    '       判定：      処理のエラー有無    例)OK: 正常終了
    '                                          NG+エラー内容： エラー時に戻す文字
    '
    '　【注意】
    '       Routes APIを利用する際、条件をjson形式の文字列にセットし、指定のURLにPOSTする。      
    '----------------------------------------------------------------------------------------------

    '緯度経度の分解--------------------------------------------------------------------------------
    Dim latA As String  'A地点緯度
    Dim lngA As String  'A地点経度
    Dim latB As String  'B地点緯度
    Dim lngB As String  'B地点経度
    
    Dim splitted As Variant
    
    splitted = Split(pointA, ",")
    latA = Trim(splitted(0))
    lngA = Trim(splitted(1))
    
    splitted = Split(pointB, ",")
    latB = Trim(splitted(0))
    lngB = Trim(splitted(1))

    
    'POST------------------------------------------------------------------------------------------
    '-----------------
    'リクエスト生成
    '-----------------
    'URL (Routes API指定のURL)
    Dim url As String
    url = "https://routes.googleapis.com/directions/v2:computeRoutes"
    
    'パラメータ (json形式で設定)
    Dim paramStr As String

    paramStr = paramStr & "{"
    paramStr = paramStr & " ""origin"":{"                               '始点
    paramStr = paramStr & "  ""location"":{"
    paramStr = paramStr & "   ""latLng"":{"
    paramStr = paramStr & "    ""latitude"": " & latA & ","
    paramStr = paramStr & "    ""longitude"": " & lngA
    paramStr = paramStr & "     }"
    paramStr = paramStr & "   }"
    paramStr = paramStr & "  },"
    paramStr = paramStr & "  ""destination"":{"                         '終点
    paramStr = paramStr & "    ""location"":{"
    paramStr = paramStr & "      ""latLng"":{"
    paramStr = paramStr & "        ""latitude"": " & latB & ","
    paramStr = paramStr & "        ""longitude"":  " & lngB
    paramStr = paramStr & "      }"
    paramStr = paramStr & "    }"
    paramStr = paramStr & "  },"
    paramStr = paramStr & "  ""travelMode"": ""DRIVE"","                '自動車指定
    paramStr = paramStr & "  ""routingPreference"": ""TRAFFIC_AWARE"","
    paramStr = paramStr & "  ""computeAlternativeRoutes"": false,"
    paramStr = paramStr & "  ""routeModifiers"": {"
    paramStr = paramStr & "    ""avoidTolls"": true,"                   '有料道路可否
    paramStr = paramStr & "    ""avoidHighways"": true,"                '高速道路可否
    paramStr = paramStr & "    ""avoidFerries"": true"                  'フェリー可否
    paramStr = paramStr & "  },"
    paramStr = paramStr & "  ""languageCode"": ""ja-jp"","              '日本語指定
    paramStr = paramStr & "  ""units"": ""metric"""                     'メートル法指定
    paramStr = paramStr & "}"
    
    
    '--------------
    'POST実行
    '--------------
    Dim xmlhttp As Object
    Set xmlhttp = CreateObject("msxml2.xmlhttp")
    'Open
    xmlhttp.Open "POST", url, False
    'ヘッダ設定
    xmlhttp.setRequestHeader "Content-Type", "application/json"
    xmlhttp.setRequestHeader "X-Goog-Api-Key", 【APIキーはここにコピペ】
    xmlhttp.setRequestHeader "X-Goog-FieldMask", "routes.duration,routes.distanceMeters,routes.polyline.encodedPolyline"
    'パラメータ送信
    xmlhttp.send (paramStr)
    
    
    '--------------
    '応答取得
    '--------------
    Dim retCd As String
    retCd = xmlhttp.Status      '結果コード取得
    
    Dim retHtml As String       '応答結果HTML
    If retCd <> 200 Then
        'Debug.Print "error:" & retCd
        GoTo 応答取得Err:
    Else
        retHtml = StrConv(xmlhttp.responsebody, vbUnicode, 1041)        '応答結果HTML取得
        'Debug.Print retHtml
    End If
    
    
    'json解析--------------------------------------------------------------------------------------
    '応答結果のjsonから必要データを抜き取る。
    
    '距離
        距離 = json解析_距離時間(retHtml, "distanceMeters")

    '時間
        時間 = Replace(json解析_距離時間(retHtml, "duration"), "s", "") 'sが付いているので削除
        
    '判定
    If 距離 = "" Or 時間 = "" Then
        判定 = "NG：値を特定できませんでした。"
    Else
        判定 = "OK"
    End If
     
     
Exit Sub
応答取得Err:
    判定 = "NG:" & retCd
Exit Sub
Err:
    判定 = "NG:" & Err.Description
End Sub

そして、JSONを解析するプロシージャがこちら。
VBA-JSONを使いたかったが、インストールが自由にできない環境なので…
止む無く自作。(TT)

Private Function json解析_距離時間(ByRef json As String, ByRef 抽出条件 As String) As String
    '[機能]----------------------------------------------------------------------------------------
    '   引数として受け取ったjasn形式の文字列から、抽出条件の値を抜き出し戻す。
    '   同じタグが複数存在する場合、は最初のタグの値を返す。
    '
    '   <引数/ByRef>
    '       json：      解析対象のjson形式の文字列
    '       抽出条件：  抽出する階層(タグ？)         例)distanceMeters
    '
    '   <戻り値>
    '　　　 抽出した値。 抽出できない場合は空白を戻す。
    '----------------------------------------------------------------------------------------------
    
    Dim i As Long
    Dim loc As Long           '文字位置
    
    Dim locMAX As Long      'jsonの最大文字数
    locMAX = Len(json)
    
    Dim chr As String
    Dim buf As String
    
    '引数チェック
    If json = "" Or 抽出条件 = "" Then
        json解析_距離時間 = ""
        Exit Function
    End If
    
    '最初の発見位置からデータを蓄積する
    loc = 1     '初期値
    loc = InStr(loc, json, 抽出条件)
    'Debug.Print "loc:" & loc
    
    loc = loc + Len(抽出条件)   '抽出条件の文字数分進める
    'Debug.Print "loc:" & loc
    
    buf = ""
    For i = loc To locMAX
        chr = Mid(json, i, 1)
        
        If chr = "," Or chr = "}" Then
            Exit For
        End If
        
        buf = buf & chr '文字蓄積
    Next i
    
    '不要文字削除
    buf = Replace(buf, """", "")
    buf = Replace(buf, ":", "")
    buf = Trim(buf)
    'Debug.Print "buf:" & buf

    json解析_距離時間 = buf

End Function

それと…Routes APIの設定画面の落とし穴がこちら↓
これを見つけるのに半日悩んだぜい。
文化の違いか…