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

どのくらい面白かった?

星を押して送信してね

平均 0 / 5. Vote count: 0

是非フォローしてください

最新の情報をお伝えします

コメントする

メールアドレスが公開されることはありません。 が付いている欄は必須項目です