【ExcelVBA】Yahoo!地図のルート検索で情報取得はできるか【SeleniumBasicなしで】【Webdriverなしで】
以前こういう記事を書いたのですが、多分これをみたであろう方から、「Googleマップでできるなら、Yahoo!地図でも同じことができないか?」というお問い合わせをいただきました。
ある一定の職場ではネットワークやパソコン環境が非常にセキュリティ面で厳しく、閉鎖的な場合があります。
そういう環境では、気軽にアプリをインストールしたり、プログラムの自動実行で必要なWebdriverやSeleniumBasicといったものをダウンロードしたりできません。
今回お問い合わせのあった方の環境もそういうところのようでした。そして、その方の場合、GoogleMapではなくYahoo!地図のルート検索で自動車の場合をご要望でした。
そこで早速調べてみました。
InternetExplorerで試す
以前書いた記事と同様、InternetExplorerを使って実行できないか試してみました。
結論から言うと、ダメでしたorz
試したコードはこちらです↓
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です)。
よく調べもせず使ってしまい訳が分からなかったのですが、あとで調べたら、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相談までどうぞ。この記事執筆時点では、無料です。ただし、当サイトのブログの記事にすることがあります。
この閉鎖空間で何とかする件については、ほとほと困っているので、この記事のコメントは許可しておきます。知見者からの情報モトム。
-
前の記事
「ろうむ署に行く」 2023.06.12
-
次の記事
【ExcelVBA】Yahoo!地図からルート検索【SeleniumBasic】 2023.06.14