ExcelVBA 住所から緯度・経度→最寄駅、路線情報、距離、時間取得

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

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

住所から最寄駅を検索する | ヴィーバ 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

Dim xhr

'最寄駅を検索するサンプル
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")

    Set xhr = CreateObject("MSXML2.XMLHTTP")    ' ★一回だけ生成

    'ワークシートから住所を取得
    Worksheets("sheet1").Select
    
    'ワークシートに描画しない
    Application.ScreenUpdating = False
    
    n_not_found = 0
    
    '住所欄を順次取得していく
    For i = 0 To 9000
        '空行なら抜ける
        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)
        
        ' ★3回連続で取得に失敗したら、処理を中断する
        If m_ListOfStation(0) = "" Then
            not_found_count = not_found_count + 1
            If not_found_count > 3 Then
                Exit For
            End If
        Else
            not_found_count = 0
        End If
            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

    Set xhr = Nothing

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=")
'        Set xhr = CreateObject("MSXML2.XMLHTTP")
        xhr.Open "GET", m_Uri, False
        xhr.Send
            '取得結果を格納
            
            Set elements = xhr.responseXML.DocumentElement
            
            If elements.getElementsByTagName("station").Length > 0 Then     ' ★ここを追加
                Set firstStation = elements.getElementsByTagName("station").Item(0)
                
                Set Child = firstStation.ChildNodes
                
                For i = 0 To Child.Length - 1
                    
                    Select Case Child.Item(i).NodeName
                    Case "name"
                        m_Return(0) = Child.Item(i).Text
                    Case "line"
                        m_Return(1) = Child.Item(i).Text
                    Case "direction"
                        m_Return(2) = Child.Item(i).Text
                    Case "distance"
                        m_Return(3) = Child.Item(i).Text
                    Case "traveltime"
                        m_Return(4) = Child.Item(i).Text
                    End Select

                Next        ' ★ここを追加
            End If
            
    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