公共測量、土木設計、用地境界測量、土木建築用測量、土地調査、各種申請etc...株式会社 滝下測量設計事務所(京都府綾部市、福知山市)

'YahooWebAPIを使用した経緯度⇔住所変換
Option Explicit

Const APPID As String = "ここにアプリケーションIDを入力"

'Yahoo!ジオコーダAPIによる住所→BL変換
'戻り値(CSV文字列)=緯度,経度,メッセージ(成功時=True,失敗時=エラーの内容)
Function Address2BLbyYahoo(ByVal Address As String) As String

    If Address = "" Then
        Address2BLbyYahoo = ",,住所が入力されていません"
        Exit Function
    End If

'URL(参照https://developer.yahoo.co.jp/webapi/map/openlocalplatform/v1/geocoder.html)
    Dim strAdr As String
    '基本
    strAdr = "https://map.yahooapis.jp/geocode/V1/geoCoder?"    '基本
    '表示件数
    strAdr = strAdr & "&results=1"
    'マッチしなかった場合、上位のレベルで再検索
    strAdr = strAdr & "&recursive=true"
    '住所検索レベル
    strAdr = strAdr & "&al=4&ar=eq"
    '住所の文字コード
    strAdr = strAdr & "&ei=SJIS"
    'アプリケーションID
    strAdr = strAdr & "&appid=" & APPID
    '住所
    strAdr = strAdr & "&query=" & Address


'取得
    Dim objMSX As Object
    Set objMSX = CreateObject("MSXML2.XMLHTTP")
    With objMSX
        .Open "GET", strAdr, False
        .send
        Dim t As Variant
        With .responseXML

            'アイテムが1以上あった
            If .getElementsByTagName("Count").Item(0).Text <> 0 Then
                '経緯度取得
                t = Split(.getElementsByTagName("Coordinates").Item(0).ChildNodes(0).Text, ",")
                '経度緯度→緯度経度にする
                Address2BLbyYahoo = t(1) & "," & t(0) & ",True"

            'アイテムがない
            Else
                t = .getElementsByTagName("Status").Item(0).Text
                If t <> "" Then
                    Address2BLbyYahoo = ",," & t
                Else
                    Address2BLbyYahoo = ",,不明なエラー"
                End If
            End If
        End With
    End With

End Function


'Yahoo!リバースジオコーダAPIによるBL→住所変換
'戻り値(CSV文字列)=住所,メッセージ(成功時=True,失敗時=エラーの内容)
Function BL2AddressbyYahoo(ByVal Lat As Double, ByVal Lon As Double) As String

    If (Lat = 0) Or (Lon = 0) Then
        BL2AddressbyYahoo = ",経緯度が入力されていません"
        Exit Function
    End If

'URL(参照https://developer.yahoo.co.jp/webapi/map/openlocalplatform/v1/reversegeocoder.html)
    Dim strAdr As String
    '基本
    strAdr = "https://map.yahooapis.jp/geoapi/V1/reverseGeoCoder?"    '基本
    'アプリケーションID
    strAdr = strAdr & "&appid=" & APPID
    '経緯度
    strAdr = strAdr & "&lat=" & Lat & "&lon=" & Lon


'取得
    Dim objMSX As Object
    Set objMSX = CreateObject("MSXML2.XMLHTTP")
    With objMSX
        .Open "GET", strAdr, False
        .send
        Dim t As Variant
        With .responseXML

            'アイテムが1以上あった
            If .getElementsByTagName("Count").Item(0).Text <> 0 Then
                '住所取得
                BL2AddressbyYahoo = .getElementsByTagName("Address").Item(0).Text & ",True"

            'アイテムがない
            Else
                t = .getElementsByTagName("Status").Item(0).Text
                If t <> "" Then
                    BL2AddressbyYahoo = ",," & t
                Else
                    BL2AddressbyYahoo = ",,不明なエラー"
                End If
            End If
        End With
    End With


End Function