Yahoo!のWeb APIを使って住所から最寄り駅を取得

readme.txt

■ 使い方

セルA1：アプリケーションID
セルA2：住所

を入力してください。
住所によっては失敗します。

testプロシーシャを実行してください。
最寄駅をメッセージボックスで表示します。
メッセージボックスに表示されるのはXMLなので、必要に応じて加工してください。

■ コードの流れ

まず、住所から緯度経度を取得します。
こちらのWeb APIを利用しています。
（アプリケーションIDの登録（無料）が必要）

Yahoo!デベロッパーネットワーク - 地図 - ジオコーダ
http://developer.yahoo.co.jp/webapi/map/openlocalplatform/v1/geocoder.html

次に、緯度経度から最寄駅を取得します。
こちらのWeb APIを利用しています。
（登録不要、無料）

HeartRails Express | 路線／駅名／最寄駅データサービス
http://express.heartrails.com/

Module1.bas

Option Explicit

' ----------------------------------------------------------------------
' 参照設定
'
' Microsoft WinHTTP Services, version 5.1
' Microsoft VBScript Regular Expressions 5.5
' ----------------------------------------------------------------------

Sub test()
    Dim ApplicationId As String
    Dim Address As String
    Dim Station As String
    
    ApplicationId = Range("A1").value
    Address = Range("A2").value
    Station = getStation(ApplicationId, Address)
    MsgBox Station
End Sub

Function getStation( _
    ApplicationId As String _
    , Optional Address As String _
    , Optional lat As String _
    , Optional lon As String _
    ) As String

    Const URI_HEARTRAILS_EXPRESS As String = "http://express.heartrails.com/api/xml?method=getStations"
    Dim Coordinate() As String
    Dim uri As String
    
    If Len(Address) > 0 Then
        Coordinate = getCoordinate(ApplicationId, Address)
        lon = Coordinate(0)
        lat = Coordinate(1)
    End If
    
    uri = URI_HEARTRAILS_EXPRESS & "&x=" & lon & "&y=" & lat
    getStation = httpGet(uri)
End Function

Function getCoordinate(ApplicationId As String, Address As String) As String()
    Const URI_GEOCODER As String = "http://geo.search.olp.yahooapis.jp/OpenLocalPlatform/V1/geoCoder"
    Const PATTERN As String = "<Coordinates>(\d+(\.\d+))?,(\d+(\.\d+)?)</Coordinates>"
    Dim uri As String
    Dim xml As String
    Dim Matches As VBScript_RegExp_55.MatchCollection
    Dim Coordinate(0 To 1) As String
    
    uri = URI_GEOCODER & "?appid=" & ApplicationId & "&query=" & Address
    xml = httpGet(uri)
    Set Matches = regMatches(PATTERN, xml)
    If Matches.Count > 0 Then
        With Matches.Item(0).SubMatches
            Coordinate(0) = .Item(0)
            Coordinate(1) = .Item(2)
        End With
        getCoordinate = Coordinate
    Else
        Err.Raise 1, , "指定された住所が見つかりません"
    End If
End Function

Function regMatches( _
    PATTERN As String _
    , Str As String _
    , Optional Global_ As Boolean = False _
    , Optional IgnoreCase As Boolean = False _
    , Optional Multiline As Boolean = False _
    ) As VBScript_RegExp_55.MatchCollection
    
    Dim reg As VBScript_RegExp_55.RegExp
    Set reg = New VBScript_RegExp_55.RegExp
    reg.PATTERN = PATTERN
    reg.Global = Global_
    reg.IgnoreCase = IgnoreCase
    reg.Multiline = Multiline
    Set regMatches = reg.Execute(Str)
End Function

Function httpGet(uri As String) As String
    Dim http As WinHttp.WinHttpRequest
    Set http = New WinHttp.WinHttpRequest
    http.Open "GET", uri, False
    http.Send
    If http.Status = 200 Then
        httpGet = http.ResponseText
    Else
        Err.Raise http.Status, , http.StatusText
    End If
End Function