Hatena::ブログ(Diary)

ひろボックス 〜備忘録〜

2013-12-07

住所 名称から最寄駅等を取得する

下記のサイトのコードを少し変えて
シートにある住所から最寄駅等の情報を作ってみました。

住所から最寄駅を検索する | ヴィーバ VeaBa! Excel VBA Tips
http://veaba.keemoosoft.com/2013/02/488/

コードを読むのに時間かかりました。。。
変更したのは直近の一件のみ取得と
シートから住所取り込んで情報を入れる部分だけです。

SimpleAPI「最寄り駅Webサービス
で緯度、経度から最寄駅、路線情報、距離、時間取得できる便利な
サービスと

緯度経度は
Google Geocoding APIを使って、検索して渡して上記の情報を
取得してくるというもの。

と参照設定でXML扱えるように
下記サイトを参考
http://d.hatena.ne.jp/end0tknr/20081115/1226755041

'最寄駅を検索するサンプル
Sub Sample_search_near_station()
    Dim i As Integer
    Dim m_ListOfStation() As String
    Dim address As String
    Dim Sheet As Object 'Excel.Worksheet
    Set Sheet = Worksheets("sheet1")

    'ワークシートから住所を取得
    Worksheets("sheet1").Select
    
    'ワークシートに描画しない
    Application.ScreenUpdating = False
    
    '住所欄を順次取得していく
    For i = 0 To 1000
        '空行なら抜ける
        If (Sheet.Cells(2 + i, 1) = "") Then
            Exit For
        Else
        address = Sheet.Cells(2 + i, 1).Value
        '最寄駅を検索するサブプロシージャの呼び出し
        m_ListOfStation = GetListOfNearestStation(GetLocation(address))
        'UBOUND関数配列の名前を指定する
        'For j = 0 To (UBound(m_ListOfStation) / 5 - 1)
            Sheet.Cells(2 + i, 2) = m_ListOfStation(0)
            Sheet.Cells(2 + i, 3) = m_ListOfStation(1)
            Sheet.Cells(2 + i, 4) = m_ListOfStation(2)
            Sheet.Cells(2 + i, 5) = m_ListOfStation(3)
            Sheet.Cells(2 + i, 6) = m_ListOfStation(4)
        'Next
        End If
    'DoEventsの実行
    '
    DoEvents
    
    Next
    
    '結果を描画する
    Application.ScreenUpdating = True
End Sub

'最寄駅を検索するファンクション
'引数  ByRef参照渡し
'       検索する建物名
Private Function GetListOfNearestStation(ByRef argLocation As String) As String()
    Dim m_Return(5) As String
    Dim m_Uri As String
    Dim m_NameElements As Object
    Dim m_LineElements As Object
    Dim m_DirectionElements As Object
    Dim m_DistanceElements As Object
    Dim m_TraveltimeElements As Object
    Dim i As Integer

    '住所入っていた場合
    If Len(argLocation) > 0 Then
        'SimpleAPI「最寄り駅Webサービスを利用
        '緯度 経度を指定して最寄駅を検索
        m_Uri = "http://map.simpleapi.net/stationapi?output=xml&y=" & _
                    Replace(argLocation, ",", "&x=")
'        With CreateObject("MSXML2.XMLHTTP")
'            .Open "GET", m_Uri, False: .Send
'            With .responseXML
        Set xhr = CreateObject("MSXML2.XMLHTTP")
        xhr.Open "GET", m_Uri, False
        xhr.Send
            '取得結果を格納
            Set elements = xhr.responseXML.DocumentElement
                Set m_NameElements = elements.getElementsByTagName("name")
                Set m_LineElements = elements.getElementsByTagName("line")
                Set m_DirectionElements = elements.getElementsByTagName("direction")
                Set m_DistanceElements = elements.getElementsByTagName("distance")
                Set m_TraveltimeElements = elements.getElementsByTagName("traveltime")
                
                'Debug.Print m_NameElements(0).Text
                
                If m_NameElements.Length > 0 Then
                    'ReDim m_Return(m_NameElements.Length, 5)
                    '検索結果すべて表示する場合
'                    For i = 1 To m_NameElements.Length
'                        '駅名の取得
'                        m_Return(i, 1) = m_NameElements.Item(i - 1).Text
'                        '路線名の取得
'                        m_Return(i, 2) = m_LineElements.Item(i - 1).Text
'                        '方角の取得
'                        m_Return(i, 3) = m_DirectionElements.Item(i - 1).Text
'                        '駅までの距離を取得
'                        m_Return(i, 4) = m_DistanceElements.Item(i - 1).Text
'                        '駅までにかかる時間の取得
'                        m_Return(i, 5) = m_TraveltimeElements.Item(i - 1).Text
'                    Next
                       '一番の最寄駅だけ取得
                        m_Return(0) = m_NameElements.Item(0).Text
                        '路線名の取得
                        m_Return(1) = m_LineElements.Item(0).Text
                        '方角の取得
                        m_Return(2) = m_DirectionElements.Item(0).Text
                        '駅までの距離を取得
                        m_Return(3) = m_DistanceElements.Item(0).Text
                        '駅までにかかる時間の取得
                        m_Return(4) = m_TraveltimeElements.Item(0).Text
                    
                Else
                    'Redim 動的配列
                    'ReDim m_Return(0)
                End If
            'End With
        'End With
    Else
        'ReDim m_Return(0)
    End If
    
    GetListOfNearestStation = m_Return
    
    'オブジェクトの破棄処理
    Set m_DirectionElements = Nothing
    Set m_LineElements = Nothing
    Set m_DirectionElements = Nothing
    Set m_DistanceElements = Nothing
    Set m_TraveltimeElements = Nothing
End Function

'緯度 経度を取得するファンクション
'引数 検索する建物
Public Function GetLocation(ByRef argAddressString As String) As String
    Dim m_Uri As String
    'Debug.Print argAddressString
    If Len(argAddressString) > 0 Then
        m_Uri = "http://maps.googleapis.com/maps/api/geocode/xml?address=" & _
        EncodeURI(argAddressString) & "&sensor=false"
        'With CreateObject("MSXML2.XMLHTTP")
        '    .Open "GET", m_Uri, False: .Send
        '
        '分割して記述した例が下
        Set xhr = CreateObject("MSXML2.XMLHTTP")
        xhr.Open "GET", m_Uri, False
        xhr.Send
        'Debug.Print m_Uri
            'With CreateObject("MSXML2.XMLHTTP").responseXML
                '取得結果を格納
                Set elements = xhr.responseXML.DocumentElement
                '情報を取得できたら格納
                If elements.getElementsByTagName("status").Item(0).Text = "OK" Then
                    'locationタグの読み込み
                    '緯度経度間の空白を,に置換
                    '置換例 35.7100327,139.8107155
                    GetLocation = Replace(elements.getElementsByTagName("location").Item(0).Text, " ", ",")
                End If
            'End With
        'End With
    End If
End Function
'URLエンコードを行うファンクション
Private Function EncodeURI(ByVal argString As String) As String
    argString = Replace(Replace(argString, "\", "\\"), "'", "\'")
    With CreateObject("HtmlFile")
        .parentWindow.execScript "document.write(encodeURIComponent('" & argString & "'));", "JScript"
        EncodeURI = .Body.innerHTML
    End With
End Function

イメージは下記。

f:id:hiroroEX:20131207214613p:image:w360

スパム対策のためのダミーです。もし見えても何も入力しないでください
ゲスト


画像認証

トラックバック - http://d.hatena.ne.jp/hiroroEX/20131207/1386420196
リンク元