【ExcelVBA】Yahoo!地図のルート検索で情報取得はできるか【SeleniumBasicなしで】【Webdriverなしで】

  • [記事公開]2023.06.13[最終更新]2023.06.14
  • VBA

以前こういう記事を書いたのですが、多分これをみたであろう方から、「Googleマップでできるなら、Yahoo!地図でも同じことができないか?」というお問い合わせをいただきました。

ある一定の職場ではネットワークやパソコン環境が非常にセキュリティ面で厳しく、閉鎖的な場合があります。

そういう環境では、気軽にアプリをインストールしたり、プログラムの自動実行で必要なWebdriverやSeleniumBasicといったものをダウンロードしたりできません。

今回お問い合わせのあった方の環境もそういうところのようでした。そして、その方の場合、GoogleMapではなくYahoo!地図のルート検索で自動車の場合をご要望でした。

そこで早速調べてみました。

InternetExplorerで試す

以前書いた記事と同様、InternetExplorerを使って実行できないか試してみました。

結論から言うと、ダメでしたorz

試したときの画面。下の方に、「InternetExplorer11は現在サポート対象外です」のメッセージが出ている。

試したコードはこちらです↓

Option Explicit
'ワークシートに表示する情報のヘッダ
Enum e
    出発地 = 1
    目的地
    時間
    距離
    TheEnd = 距離
End Enum

'InternetExplorer
Public ie As InternetExplorer
'
'作成:野口香
'作成:2023/06/12
'
Public Sub GetMap()
    '作業用シート
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets(1)
    
    'InternetExplorerを用意
    Set ie = New InternetExplorer
    
    'IE(InternetExplorer)を表示する
    ie.Visible = True
    
    'Yahoo地図のURLへ遷移
    ie.navigate "http://map.yahoo.co.jp/route/car"
    Call ieWaitTime 'ieの読み込み待ち
    
    'ブラウザを最大サイズに。これをすると手動で元のサイズに戻せない。戻すときはFullScreen = False
    'デバッグ中、残ってしまったブラウザを終了させるときはAlt+F4
    ie.FullScreen = True
    Call ieWaitTime 'ieの読み込み待ち
    
    '前回までの情報をクリアしておく
    Const clHeader As Long = 2  'ヘッダ行の行番号
    sh.Range(sh.Cells(clHeader + 1, e.時間), sh.Cells(sh.Rows.Count, e.TheEnd)).ClearContents
    
    'Loop開始前、準備
    Dim ii As Long, lRow As Long
    Const cstStart As Long = 3
    lRow = sh.Cells(cstStart, e.目的地).End(xlDown).Row    '調査対象のレコード件数を把握する
    If lRow = sh.Rows.Count Then    '行数が最大値の場合、レコードが1件だけということなので、修正。
        lRow = cstStart
    End If
    
    Dim el As HTMLInputElement, xp As XPath
    Dim bn As HTMLButtonElement, te As HTMLTextElement
    Dim html As HTMLDocument
    Set html = New HTMLDocument
    Set html = ie.document
    
    'Loop突入
    For ii = cstStart To lRow
        
        '出発地
        Set el = html.querySelector("#route_start")
        Call ieWaitTime 'ieの読み込み待ち

        el.Value = sh.Cells(ii, e.出発地).Value
        Call ieWaitTime 'ieの読み込み待ち
        
        '目的地
        Set el = html.querySelector("#route_goal")
        Call ieWaitTime 'ieの読み込み待ち
        
        el.Value = sh.Cells(ii, e.目的地).Value
        Call ieWaitTime 'ieの読み込み待ち
        el.Focus    'このFocusがないと出発地と目的地のInputTextがdeleteされてしまうので。
        
        '検索ボタンをクリック
        Set bn = html.querySelector("#search_route_page > div > div.SearchRouteForm__submit > button")
        Call ieWaitTime 'ieの読み込み待ち
        bn.Click
        Call ieWaitTime 'ieの読み込み待ち
        
        'Webサイトの表示情報が更新されたので、いったんHtml.documentを取り直す←本来これはいらないはずだけど、次の「時間を取得」のステップでエラーが頻発したので入れてみた。
        Set html = ie.document
        Call ieWaitTime 'ieの読み込み待ち
       
        '時間を取得
        Set te = html.querySelector("#search_route_page > div.SearchRouteResults.SearchRouteResults--car > ul > li:nth-child(1) > button > div > div.SearchRouteResults__listItemButtonContentHeading > div")
        Call ieWaitTime 'ieの読み込み待ち
        sh.Cells(ii, e.時間).Value = te.innerText
        Call ieWaitTime 'ieの読み込み待ち
        
        '距離を取得
        Set te = html.querySelector("#search_route_page > div.SearchRouteResults.SearchRouteResults--car > ul > li:nth-child(1) > button > div > div.SearchRouteResults__listItemButtonContentHeading > span")
        Call ieWaitTime 'ieの読み込み待ち
        sh.Cells(ii, e.距離).Value = te.innerText
        Call ieWaitTime 'ieの読み込み待ち

    Next ii
    
    '終了
    ie.Quit
    
    'オブジェクト解放
    Set sh = Nothing
    Set te = Nothing: Set bn = Nothing
    Set ie = Nothing: Set el = Nothing
    
    '終了メッセージ
    MsgBox "終了"
    
End Sub

'読込待ち処理
Public Function ieWaitTime()

    'ieがBusy(処理中なら)DoEventsで待機
    Do While ie.Busy = True
        DoEvents
    Loop
    
    'ieがREADYSTATE_COMPLETE(全データ読込完了になるまで)DoEventsで待機
    Do While ie.readyState <> READYSTATE_COMPLETE
        DoEvents
    Loop
    
    '操作が安定するよう念を入れて待機
    Application.Wait [Now() + "00:00:01"]
End Function


Set el = html.querySelector(“#route_start”)

のところでアウトです。ここは出発地の要素をCSSセレクタで調べるところなんですが、そもそもYahoo!地図からまともに情報が返ってきていないので、#route_startの要素が見つかる訳もなく、あえなくエラーとなりました。

Yahoo!地図からどんな情報が返ってきたのか、innerHTMLの中身をデバッグで見てみると

<div class="noScript">
<div class="noScript__message">
<p>JavaScriptが無効です。<br/>Yahoo!地図 を正しくご利用いただくにはJavaScriptの設定を「有効」にする必要があります。</p>
<p>

というように、JavaScriptが無効のときのメッセージが返ってきていました(見やすいように適宜改行コードを加えてあります)。

Yahoo!地図の場合、ブラウザで表示したときにJavaScriptが動くようになっているのでしょうね。JavaScriptを使わず、HTMLだけで情報をゲットしようとしてもダメってことなんでしょうね。

URLで開く方法を試す

Yahoo!地図の仕様を見ると、自動車でルート検索するときのURLは、例えば次のようになるそうです。

https://map.yahoo.co.jp/route/car?from=東京駅&to=新宿駅

car?の後に、from=と入れて起発地点を、次に&でつなげてto=に到着地点を入れればよいようです(これをみました)。

URLを作るだけならExcelでもできます。そのあとそのURLをHTTP通信で開けばうまくいかないだろうか?と考えました。

試しに作ったのが↓このコードです。

Option Explicit

Public Sub GetYahooMap()
    Dim stPath As String
    stPath = "https://map.yahoo.co.jp/route/car?from="

    stPath = stPath & "東京駅" & "&to=" & "高崎駅"
    
    Dim client As Http
    Set client = New Http
    
    Dim response As String
    response = client.GetPage(stPath)
    
    Dim localHtml As Object
    Set localHtml = New HTMLDocument
    
    localHtml.write response
    
    Dim nodes As Object
    Set nodes = localHtml.getElementsByTagName("div")
    
    Dim node As Object 'HTMLUListElement
    Const cstClassName As String = "SearchRoute target_modules"
    For Each node In nodes
        If node.className = cstClassName Then
            Debug.Print node.innerText
        End If
    Next node
    
    Set nodes = Nothing
    Set localHtml = Nothing
    Set client = Nothing
End Sub

このコード内で使っているHttpというクラスは下記です(以前別の記事で他サイトから借用して使ったものです)。

Option Explicit

'HTTP通信用クラス

Private client As Object
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)

'コンストラクタ


Private Sub Class_Initialize()
    Set client = CreateObject("MSXML2.ServerXMLHTTP")
End Sub

'デストラクタ

Private Sub Class_Terminate()
    Set client = Nothing
End Sub

'引数のURLをGETで取得
'
'url:URL文字列
'return:取得したページ
'
Public Function GetPage(URL As String) As String

    client.Open "GET", URL
    
    Sleep 2000 'スクレイピングのマナー(1000以上を設定のこと)
    client.Send
    
    'readyStateの値が4で読み込みが完了
    Do While client.readyState < 4
        DoEvents
    Loop
    
    
    Dim statusCode As Integer
    statusCode = client.Status
    
    Dim responseText As String
    Dim lNum1 As Long, lNum2 As Long, stMoji As String
    
    'HTTPのステータスコードが200(OK)以外であれば、ステータスコードなどを返す
    If (statusCode = 200) Then
    
        '取得した文字列を変数へ
        responseText = client.responseText
        
        '文字コード把握
        lNum1 = InStr(1, responseText, "charSet")
        lNum2 = InStr(lNum1, responseText, ">")
        stMoji = Mid(responseText, lNum1, lNum2 - lNum1)
        stMoji = Replace(stMoji, "charSet", "")
        stMoji = Replace(stMoji, "=", "")
        stMoji = Replace(stMoji, "/", "")
        stMoji = Replace(stMoji, " ", "")
        stMoji = Replace(stMoji, """", "")
        Select Case LCase(stMoji)
            Case "utf-8"
                GetPage = client.responseText
            Case Else
                GetPage = StrConv(client.responseText, vbUnicode)
        End Select
    Else
        GetPage = "HTTP StatusCode:" & statusCode & "," & vbCrLf & "HTTP StatusText:" & client.statusText
    End If
End Function

結論から言うと、これもうまくいきませんでした。

HTTPのステータスコードが200(正常)ではなく400(異常)が返ってきていました。

中身を見ると、次のとおりでした。

HTTP StatusCode:400,
HTTP StatusText:Invalid HTTP Request

やっぱりHTTPだけではうまくいかないようです。どうしてもブラウザを介して、JavaScriptを動かさないといけないのではないかという気がしてきました。

そこで、次に考えたのが、HyperLinkで開く方法でした。

HyperLinkで開く方法

参考にしたのはこちらのサイトです。

Webページ内のHTMLを取得するVBAコード

https://officevba.info/gethtmlelement/

こちら↑にあるコードを参考に、URLを開く部分はHyperLinkで開くように変更しました。

作ったコードはこちら↓です。

Option Explicit
'
'下記サイトを参考にしました。
'VBA・GAS・Pythonで仕事を楽しく効率化
'Webページ内のHTMLを取得するVBAコード
'https://officevba.info/gethtmlelement/
'
Sub HTMLの情報を取得してテキストに書き出す()

    Dim FSO As Object, WSH As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set WSH = CreateObject("Wscript.Shell")
    
    Dim DesktopPath As String
    DesktopPath = WSH.SpecialFolders("Desktop")
    
    Dim HTMLコード As String
    
    Dim colSh  As Object
    Set colSh = CreateObject("Shell.Application")
    
    'アクティブシートのセルC6にURL"https://map.yahoo.co.jp/route/car?from=高崎駅&to=東京駅"が入っている
    Dim r As Range
    Set r = ActiveSheet.Range("C6")
    ActiveSheet.Hyperlinks.Add(Anchor:=r, _
                      Address:=r.Value, _
                      TextToDisplay:=r.Value).Follow
    Set r = Nothing
                      
    Dim wins As Object
    Set wins = colSh.Windows    '現在開いているWindowを把握
    
    Dim win As Object
    Dim objIE As Object
    For Each win In wins
        If TypeName(win.document) = "HTMLDocument" Then
            If InStr(win.document.Title, "Yahoo!地図") > 0 Then
                Set objIE = win
                Exit For
            End If
        End If
    Next
    
    If objIE Is Nothing Then
        MsgBox "入力するページが見つかりません"
    Else
    
    HTMLコード = objIE.document.body.outerHTML
    With FSO.CreateTextFile(DesktopPath & "\HTML.txt")
        .WriteLine HTMLコード
        .Close
    End With
    
    End If
    
    Set FSO = Nothing
    Set colSh = Nothing
    
    Set WSH = Nothing
    Set wins = Nothing
    Set win = Nothing
    Set objIE = Nothing
    
End Sub

このコードもうまくいきませんでした。

これは、

If TypeName(win.document) = “HTMLDocument” Then

のところでエラーとなりました。

エラーとなったときのメッセージ

デバッグ中にローカルウィンドウで見てみると、そもそも「HTMLDocument」ではなく「IWebBrowser2」というオブジェクトになっていました(私のデフォルトで開くブラウザはChromeです)。

winsのItem一つ一つがIWebBrowser2という型になっており、win.Documentにはそもそも値が設定されていませんでした。

よく調べもせず使ってしまい訳が分からなかったのですが、あとで調べたら、HTMLDocumentというのはInternetExplorerのことだと分かりました。

現在ではInternetExplorerは使われていませんので、上記のコードはかつて使えたけど今は使えない、古いコードだったということです・・・orz

とにかくTextベースでとってきて正規表現でなんとかする方法

最後に試したのが、こちら↓のサイトにあった方法です。

ExcelのVBAでYahoo!路線情報からHTMLを取得して運賃を取得してみる

https://qiita.com/granpa/items/c0a06011654b40bd6e16

HTMLというのは、要はテキストです。

テキストベースで情報をとってきて、あとはそれを正規表現で加工して必要な情報を取り出してしまおうというのが上記サイトのやり方です。

これを真似して私も(途中まで)やってみました。

作ったコードはこちらです(途中までです)。

Option Explicit


'******************************************
'Yahoo!地図ルート検索
'https://map.yahoo.co.jp/route/car
'******************************************
Public Sub cmd_Click()

    Dim s出発 As String
    Dim s到着 As String
    Dim w_URL As String
    Dim objHttp As Object
    Dim strHtml As Variant
    Dim wstrHtml As Variant
    Dim i As Integer
    Dim matchArray As Variant
    Dim subMatchArray As Variant
    Dim rc

    With ThisWorkbook.Sheets("Sheet1")
'        .Range("C5:F8").ClearContents

        s出発 = .Range("A3")
        s到着 = .Range("B3")
        If s出発 = "" Or s到着 = "" Then Exit Sub      '入力漏れがある場合は処理しない。

        '文字コードをUTF-8に変換
        s出発 = Application.WorksheetFunction.EncodeURL(s出発)
        s到着 = Application.WorksheetFunction.EncodeURL(s到着)

        'Yahoo!地図ルート検索URLを作成する
        'https://map.yahoo.co.jp/route/car?from=大阪&to=京都
        w_URL = "https://map.yahoo.co.jp/route/car?from=" & s出発 & "&to=" & s到着 & "&sort=1&lat=36.00895&lon=138.96940&zoom=8&maptype=basic"
        Set objHttp = CreateObject("MSXML2.XMLHTTP.3.0")    'XMLHTTPオブジェクトを作成
        objHttp.Open "GET", w_URL, False                    'HTTPリクエストを作成する false:同期処理
        objHttp.send                                        'HTTPリクエストをサーバに送信する
        strHtml = objHttp.responseText                      'HTMLソースを取得する
        strHtml = Replace(strHtml, Chr(34), "", 1, -1, vbBinaryCompare)     '正規表現を簡単にするためにダブルクオーテーションを除去
        strHtml = Replace(strHtml, vbLf, "", 1, -1, vbBinaryCompare)        '正規表現を簡単にするために改行(\n)を除去

        '区間を取得する
        rc = RegExpMatch(strHtml, "<h1 class=title>(.*?)</h1>", matchArray, False, True)
        If rc Then
            .Range("C5").Value = RegExpReplace(matchArray(1, 0), "", "<([^]*|'[^']*'|[^'>])*>", False, True)     'タグの除去 区間
        End If

        '区間を取得する
        rc = RegExpMatch(strHtml, "<a href=#route0(.*?)</ul>", matchArray, False, True)
        If rc Then
            For i = 0 To 2
                wstrHtml = matchArray(1, UBound(matchArray, 2))

                'ルートx
                rc = RegExpMatch(matchArray(1, i), "</span>(.*?)</a>", subMatchArray, False, True)
                If rc Then
                    .Range("C6").Offset(i, 0).Value = RegExpReplace(subMatchArray(1, 0), "", "<([^]*|'[^']*'|[^'>])*>", False, True)    'タグの除去 区間
                End If

                '10:10 → 12:10
                rc = RegExpMatch(matchArray(1, i), "<li class=time>(.*?)<span class=small>", subMatchArray, False, True)
                If rc Then
                    .Range("C6").Offset(i, 1).Value = RegExpReplace(subMatchArray(1, 0), "", "<([^]*|'[^']*'|[^'>])*>", False, True)    'タグの除去 区間
                End If

                '時間
                rc = RegExpMatch(matchArray(1, i), "<span class=small>(.*?)</span>", subMatchArray, False, True)
                If rc Then
                    .Range("C6").Offset(i, 2).Value = RegExpReplace(subMatchArray(1, 0), "", "<([^]*|'[^']*'|[^'>])*>", False, True)    'タグの除去 区間
                End If

                '料金
                rc = RegExpMatch(matchArray(1, i), "<li class=fare>(.*?)</li>", subMatchArray, False, True)
                If rc Then
                    .Range("C6").Offset(i, 3).Value = RegExpReplace(subMatchArray(1, 0), "", "<([^]*|'[^']*'|[^'>])*>", False, True)    'タグの除去 区間
                End If
            Next
        End If
    End With
End Sub
 '-------------------------------------------
 ' マッチ
 ' [string_]内に[patrn_]と一致するものを検索する、その結果と、一致するものの文字位置と文字を返す
 '-------------------------------------------
 ' 引数
 '   string_     : 検索対象文字列
 '   patrn_      : 検索パターン
 '   AnsArray_   :
 '   IgnoreCase_ : 大文字と小文字を区別指定
 '                 true  : 大文字と小文字を区別します
 '                 false : 大文字と小文字を区別しない
 '   Global_     : 検索範囲指定
 '                 true  : 文字列全体を検索する
 '                 false : 最初の一致まで検索する
 '
 ' 戻り値
 '   RegExpMatch : false     検索結果で一致するものが存在しない
 '               : true      検索結果で一致するものが存在する
 '   AnsArray(x,y)           一致するものの文字位置と文字
 '   AnsArray(0,y)           一致するものの文字位置
 '   AnsArray(1,y)           一致する文字
 '-------------------------------------------
 Private Function RegExpMatch(string_, patrn_, AnsArray_, IgnoreCase_, Global_)
        Dim regEx: Set regEx = CreateObject("VBScript.RegExp")             ' 正規表現を作成します。
        Dim Match                                                          ' 一致文字位置と文字コレクションを受け取るWK
        Dim Matches                                                        ' 検索実行結果を受け取る
        Dim fAnsArray(): ReDim fAnsArray(1, 0)                             ' 一致するものの文字位置と文字配列

        regEx.Pattern = patrn_                                             ' パターンを設定します。
        regEx.IgnoreCase = IgnoreCase_                                     ' 大文字と小文字を区別
        regEx.Global = Global_                                             ' 検索範囲指定

        Set Matches = regEx.Execute(string_)                               ' 検索を実行します。(検索結果で一致するものがなくても配列が返る)

        RegExpMatch = False                                                ' 検索結果で一致するものが存在しないにする
        For Each Match In Matches                                          ' Matches コレクションに対して繰り返し処理を行います。
            If RegExpMatch Then
               ReDim Preserve fAnsArray(1, UBound(fAnsArray, 2) + 1)       ' AnsArrayの拡張
            End If
            RegExpMatch = True                                             ' 検索結果で一致するものが存在する
            fAnsArray(0, UBound(fAnsArray, 2)) = Match.FirstIndex          ' 一致する文字列が見つかった位置
            fAnsArray(1, UBound(fAnsArray, 2)) = Match.Value               ' 一致した文字列
        Next

        AnsArray_ = fAnsArray

        Set regEx = Nothing                                                ' 正規表現を作成します
        Set Match = Nothing                                                ' 一致文字位置と文字コレクションを受け取るWK
        Set Matches = Nothing                                              ' 検索実行結果を受け取る
        Erase fAnsArray
 End Function

 '-------------------------------------------
 ' 置換
 ' [string_]内に[patrn_]と一致するものを[replStr_]へ置換を行った結果を返す
 '-------------------------------------------
 ' 引数
 '   string_     : 検査対象文字列
 '   replStr_    : 置換え文字列
 '   patrn_      : 検査パターン
 '   IgnoreCase_ : 大文字と小文字を区別指定
 '                 true  : 大文字と小文字を区別します
 '                 false : 大文字と小文字を区別しない
 '   Global_     : 検索範囲指定
 '                 true  : 文字列全体を検索する
 '                 false : 最初の一致まで検索する
 ' 戻り値
 '   RegExpReplace : 置換を行った結果
 '-------------------------------------------
 Private Function RegExpReplace(string_, replStr_, patrn_, IgnoreCase_, Global_)
        If IsNull(string_) Or string_ = "" Then
           RegExpReplace = ""
           Exit Function
        End If

        Dim regEx: Set regEx = CreateObject("VBScript.RegExp")             ' 正規表現を作成します。
        regEx.Pattern = patrn_                                             ' パターンを設定します。
        regEx.IgnoreCase = IgnoreCase_                                     ' 大文字と小文字を区別
        regEx.Global = Global_                                             ' 検索範囲指定
        RegExpReplace = regEx.Replace(string_, replStr_)                   ' 置換します。
        Set regEx = Nothing
 End Function

これもうまくいきませんでした。

あ、上記コードはデバッグしながら修正していったので、ほとんど上記サイトで紹介されているままです。正規表現部分は全くいじっていません。

そもそも正規表現のところまでたどりつけなかったです。

MSXML2.XMLHTTP.3.0という通信規格でURLを投げて、Webから帰ってきたレスポンスを正規表現で加工するというものなんですが、先に紹介したHttpクラスを使ったやり方と同じ考え方でした。つまり、うまくいきません。

うまくいく訳がないのです、JavaScriptが動かないんだから。

元のサイトで紹介されていたYahoo!路線検索はおそらくJavaScriptがなくても情報を表示する仕組みになっているのでしょう。今回調べているYahoo!地図ではダメでした。

結論

という訳で、SeleniumBasicもWebdriverも使わず、Yahoo!地図のルート検索をVBAで使う方法を模索しましたが、見つかりませんでした。

お問い合わせをいただいた方には、「残念ながら・・・」とお返事をしました。

このように、私の技術では解決できないこともあります。

でも、解決できることもありますので、もし何か当サイトに書いてあるようなことでお困りごとがありましたら、Excel相談までどうぞ。この記事執筆時点では、無料です。ただし、当サイトのブログの記事にすることがあります。

この閉鎖空間で何とかする件については、ほとほと困っているので、この記事のコメントは許可しておきます。知見者からの情報モトム。