VBScriptでYahoo! Open Local PlatformのAPIを使って、住所→緯度経度変換してみた件

目的

程々の数の住所データを緯度経度データにいっぺんに変換したい

前提

• Windows10+Officeがインストールされた環境で何も追加インストールせずに動作する事。
• 今回はGoogle Maps APIではなく、Yahoo! Open Local Platformの方を使ってみる
• 変換するデータと結果はExcelにまとめる

注意点

• YOLPAPIKEYの中身をご自分で登録したアプリケーションIDに変更しないと動作しません。
• 一応Excelファイルの内容を書き換えるScriptなので、フォーマットチェックをしています(ソースを「ADDRESS」で検索)。

ソースコード

テスト目的で適当に作ったせいで関数化も適当なので、コード的にはあまり参考にはならないかも知れませんがご容赦を

Const   YOLPAPIKEY="<<<Your Application ID Here.>>>"

Function    Retleave(strAddress)

    Dim objHTTP : Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")

    objHTTP.Open "GET", "https://map.yahooapis.jp/geocode/V1/geoCoder?appid="+YOLPAPIKEY+"&category=address&query="+strAddress, False
    objHTTP.SetRequestHeader "Content-Type", "application/json"
    objHTTP.Send()

'   wscript.echo "status: " & objHTTP.status
'   wscript.echo "ResponseText: " & objHTTP.ResponseText

    If objHTTP.status = 200 Then
        Retleave =  objHTTP.ResponseText
    Else
        Retleave = ""
    End If
    Set objHTTP = Nothing

End Function



Function    Parse(byVal strXML, byRef strAddr, byRef lngLat, byRef lngLng)

    Parse=False
'   WScript.echo strXML
    Dim objDom, strResult
    Set objDom = WScript.CreateObject("MSXML2.DOMDocument")
    rtResult = objDom.loadXML(strXML)

    If rtResult = True Then

        Set xmlName = objDom.SelectSingleNode("//YDF/Feature/Name")
        Set xmlTotal = objDom.SelectSingleNode("//YDF/ResultInfo/Total")
        Set xmlCood = objDom.SelectSingleNode("//YDF/Feature/Geometry/Coordinates")

'       WScript.echo xmlName.Text
'       WScript.echo xmlCood.Text
        If  xmlTotal.Text = "0" Then
            MsgBox "住所から緯度経度を求められませんでした、スキップします。"
        Else
            aryCood=split(xmlCood.Text,",")
            strAddr=xmlName.Text
            lngLat=CStr(aryCood(1))
            lngLng=CStr(aryCood(0))
            Parse=True
        End If
    Else
        WScript.echo "Error"

        WScript.Echo objDom.parseError.errorCode
        WScript.Echo objDom.parseError.reason
        WScript.Echo objDom.parseError.line
        WScript.Echo objDom.parseError.linepos
        WScript.Echo objDom.parseError.filepos
        WScript.Echo objDom.parseError.srcText
        WScript.Echo objDom.parseError.url
        WScript.Quit

    End If

End Function



Sub Main

    Dim objXL
    On Error Resume Next

    Set objXL = Nothing
    Set objXL = CreateObject("Excel.Application")
    If objXL Is Nothing Then
        ' Excelが起動できなかった
        MsgBox "Excelが起動出来ません、処理を停止します"
    Else
        'Excelを表示しておくと、処理しているのが見えるので利用者が安心する
        objXL.Application.Visible = true

        objXL.Application.Workbooks.Open(wscript.Arguments(0))
        Dim strXML
        Dim nRow, lngLat, lngLng
        lngLat = 0.0
        lngLng = 0.0
        nRow = 2
        Set objSheet = objXL.Worksheets(1)
        If  (objSheet.Range("A1").value = "ADDRESS") AND (objSheet.Range("B1").value = "LAT") AND (objSheet.Range("C1").value = "LNG") Then

            While   Len(objSheet.Cells(nRow,1).Value) > 0

                strXML = Retleave(CStr(objSheet.Cells(nRow,1).value))

                objSheet.Cells(nRow,6).value = strXML
                objSheet.Cells(nRow,6).wrapText = False

                if Parse(strXML, strAddr, lngLat, lngLng) Then
                    objSheet.Cells(nRow,4).wrapText = False
                    objSheet.Cells(nRow,5).wrapText = False
                    objSheet.Cells(nRow,2).value = lngLat
                    objSheet.Cells(nRow,3).value = lngLng
                    objSheet.Cells(nRow,4).value = "https://www.google.com/maps?q="+CStr(lngLat)+","+CStr(lngLng)
                    objSheet.Cells(nRow,5).value = strAddr
                End If

                nRow = nRow+1
                WScript.Sleep(1500)
            Wend

            MsgBox "検索処理が終了しました、Excelファイルを確認してください。"

        Else
            MsgBox "Excelファイルのフォーマットが異なる為、実行できませんでした。"
        End If

         objXL.Quit
    End If

    Set objXL = Nothing

End Sub

Call    Main