注意点:住所⇔緯度・経度変換にはGoogle Geocoding APIを利用しているので、このAPIの使用制限が適用される。しかも一括変換しようとすると、10件くらいまではすぐに変換してくれるけど、それ以降は1秒に1個くらいのペースでリクエストしないとエラー(status:"OVER_QUERY_LIMIT")になる。
vba独自の注意点:エディタが大文字小文字を勝手に変換することがあるが、連想配列のキーは大文字小文字を区別するので勝手に変換されるとエラーになる。例えば、以下のコードの「jsn.status」が「jsn.Status」になるとダメ。対処法は、
Dim l As Variant l = AddressToLatLng("東京都新宿区西新宿2−8−1") MsgBox "lat:" & l(0) & vbCrLf & "lng:" & l(1) MsgBox LatLngToAddress(l(0), l(1)) '住所から緯度・経度に変換 '戻り値は配列で、(0)が緯度、(1)が経度。 Function AddressToLatLng(ByVal address As String) As Variant Dim sc As Object Dim jsn As Object Dim result As Object Dim http As Object Dim url As String Set sc = CreateObject("ScriptControl") sc.Language = "JScript" sc.AddCode "function getLatLng(s) { return eval('(' + s + ')');}" url = "http://maps.google.com/maps/api/geocode/json?sensor=false&address=" & sc.CodeObject.encodeURI(address) Set http = CreateObject("MSXML2.XMLHTTP") http.Open "GET", url, False http.Send Set jsn = sc.CodeObject.getLatLng(http.ResponseText) If jsn.status = "OK" Then For Each result In jsn.results AddressToLatLng = Array(result.geometry.location.lat, result.geometry.location.lng) Exit For Next Else 'エラー AddressToLatLng = Array(999, 999) End If Set jsn = Nothing Set sc = Nothing End Function '緯度・経度から住所に変換 Function LatLngToAddress(ByVal lat As Double, ByVal lng As Double) As String Dim sc As Object Dim jsn As Object Dim result As Object Dim http As Object Dim url As String Dim text As String Set sc = CreateObject("ScriptControl") sc.Language = "JScript" sc.AddCode "function getAddress(s) { return eval('(' + s + ')');}" url = "http://maps.google.com/maps/api/geocode/json?sensor=false&language=ja&latlng=" & lat & "," & lng Set http = CreateObject("MSXML2.XMLHTTP") http.Open "GET", url, False http.Send 'ReplaceはShift_JISに無いハイフンが返されるためこれを全角ハイフンに変換 Set jsn = sc.CodeObject.getAddress(Replace(http.ResponseText, ChrW(&H2212), "−")) If jsn.status = "OK" Then For Each result In jsn.results '「日本, 住所」の形で格納されてるので住所部分のみを取得 LatLngToAddress = Split(result.formatted_address, ", ", 2)(1) Exit For Next Else 'エラー LatLngToAddress = "" End If Set jsn = Nothing Set sc = Nothing End Function