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

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

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

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

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

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

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