スナックelve 本店

バツイチ40代女の日記です

2点間の距離を知りたい(ヤフーのAPI使う)

なんかグーグルのapiいきなり支払いとか英語できそうで怖い(先入観)からヤフーのAPI使うよ(笑)
developer.yahoo.co.jp

なんかアプリケーション作るとClient IDってのが発行されるのでどっかにコピペしておきましょう。
API使うときに「アプリケーションID」とか急に出てくるのでソレがコレでした。焦ったw

住所→緯度経度を出す→2点間の距離を出す というステップです。
実行イメージ

エラーの処理が怪しい。変な住所入れると止まるかもw

Option Explicit
Public ClientID As String

Sub mein()
ClientID = "XXXX"

Dim r As Integer
Dim strData

r = 2
'緯度経度セット
Do Until Cells(r, 2) = ""
    Range(Cells(r, 3), Cells(r, 4)).ClearContents
    If ActiveSheet.Cells(r, 2).Value <> "" Then
        strData = Split(緯度経度取得(ActiveSheet.Cells(r, 2).Value), ",")
         
        ActiveSheet.Cells(r, 3).Value = Val(strData(0)) '緯度
        ActiveSheet.Cells(r, 4).Value = Val(strData(1)) '経度
     
    End If
    r = r + 1
Loop

r = 3
'2点間距離
Do Until Cells(r, 2) = ""
    Dim distance As String: distance = 距離取得(Range("C2"), Range("D2"), Cells(r, 3), Cells(r, 4))
    Cells(r, 5) = distance
    r = r + 1
Loop

End Sub
Function 緯度経度取得(ByVal adress As String) As String
    Dim ret
    Dim retStr As String
    Dim URL As String
    adress = WorksheetFunction.EncodeURL(adress)
    URL = "https://map.yahooapis.jp/geocode/V1/geoCoder?appid=" & ClientID & "&query=" & adress
    ret = WorksheetFunction.WebService(URL)
    
    If WorksheetFunction.FilterXML(ret, "//ResultInfo/Count") <> "0" Then
        緯度経度取得 = WorksheetFunction.FilterXML(ret, "//Feature[1]/Geometry/Coordinates")
    Else
        緯度経度取得 = "取得不能,取得不能"
    End If

End Function
Function 距離取得(ido1 As Double, keido1 As Double, ido2 As Double, keido2 As Double) As String
Dim coordinates As String: coordinates = ido1 & "," & keido1 & " " & ido2 & "," & keido2
Dim URL As String: URL = "https://map.yahooapis.jp/dist/V1/distance?appid=" & ClientID & "&coordinates=" & coordinates

Dim ret: ret = WorksheetFunction.WebService(URL)

If WorksheetFunction.FilterXML(ret, "//ResultInfo/Count") <> "0" Then
    距離取得 = WorksheetFunction.FilterXML(ret, "//Feature[1]/Geometry/Distance")
Else
    距離取得 = "取得不能"
End If


End Function