2011年04月08日

vba:住所⇔緯度・経度変換

vbaで住所から緯度・経度に変換する関数と、逆の緯度・経度から住所に変換する関数。
注意点:住所⇔緯度・経度変換にはGoogle Geocoding APIを利用しているので、このAPIの使用制限が適用される。しかも一括変換しようとすると、10件くらいまではすぐに変換してくれるけど、それ以降は1秒に1個くらいのペースでリクエストしないとエラー(status:"OVER_QUERY_LIMIT")になる。
vba独自の注意点:エディタが大文字小文字を勝手に変換することがあるが、連想配列のキーは大文字小文字を区別するので勝手に変換されるとエラーになる。例えば、以下のコードの「jsn.status」が「jsn.Status」になるとダメ。対処法は、一度「status」で変数宣言する。そうすればその後変数宣言を消しても小文字のままになる。CallByName関数を使う。CallByName(jsn, "status", vbGet)


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
posted by 忘却の達人 at 21:10| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする
この記事へのコメント
コメントを書く
お名前:

メールアドレス:

ホームページアドレス:

コメント:

認証コード: [必須入力]


※画像の中の文字を半角で入力してください。
この記事へのトラックバックURL
http://blog.seesaa.jp/tb/194905106

この記事へのトラックバック