【ExcelVBA】Web情報でシートを作成しリンクを貼る【Seleniumなしでスクレイピング】【Firefox】Part2

[記事公開]2023.02.08[最終更新]2023.02.11
VBA
ExcelVBA, Firefox

この記事の続きです。

1. tabtopics7における問題点
2. エレメントIDを見つける応用
- 2.1. エレメントからエレメントを見つける
- 2.2. エレメントから複数のエレメントを見つける
3. まとめ

tabtopics7における問題点

上図はYahoo!トップのtabtopics1です。

上図はtabtopics7です。

他のtabtopicsでは一つのテーマだけなのに、tabtopics7ではITと科学に分かれている点に違いがあります。

単純にtabtopics配下のエレメントを調べ、<a>タグならとってくるようにできないということになります。

調査に使ったコードはこちらです。

Option Explicit

Sub YahooTopからカテゴリ別にシートを自動生成しリンクを貼る()
    'Webdriverの起動。Firefoxはデフォルトで4444番ポートを監視
    Shell "C:\drivers\geckodriver.exe", vbMinimizedNoFocus

    'ブラウザ起動パラメータの作成
    Dim params As New Dictionary
    params.Add "capabilities", New Dictionary
    params.Add "desiredCapabilities", Nothing

    'HTTPクライアントの起動
    Dim client As Object
    Set client = CreateObject("MSXML2.ServerXMLHTTP")
    
    'ブラウザ起動(デバッグ時に確認しやすいよう、こまめに変数に拾っていく方針)
    Const cstLocalhost As String = "http://localhost:4444/session"
    Dim oBuf As Object
    Set oBuf = SendRequest(client, "POST", cstLocalhost, params)
    
    'ブラウザ起動処理の戻り値からSessionIdを取得
    Dim sessionId As String
    sessionId = oBuf("value")("sessionId")

    'URL遷移用のパラメータを定義
    Set params = New Dictionary
    Const cstYahooUrl As String = "https://www.yahoo.co.jp/"
    params.Add "url", cstYahooUrl

    '遷移
    SendRequest client, "POST", cstLocalhost & "/" + sessionId + "/url", params
    
    'タブトピックスを探すためのパラメータを準備
    Set params = New Dictionary
    params.Add "using", "css selector"
    params.Add "value", "[role=""tab""]"    'F12で観察したところタブトピックスはすべて"tab"をもっていた。
    
    'タブトピックスを探して`elementId`に控えておく
    Dim elementId As String
    Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/elements", params)
    '↑elementでなくelementsであることに注意！複数の要素のIDが返される。
    
    Dim elements As Collection
    Set elements = New Collection
    Set elements = oBuf("value")
    
    Dim stText As String
    Dim lCnt As Long
    lCnt = elements.Count
    Const cstE As String = "element-6066-11e4-a52e-4f735466cecf"    'この名称がとても長いので可読性を上げるためにコンスト値とする。
    Dim ii As Long
    Dim sh As Worksheet
    For ii = 1 To lCnt
        stText = SendRequest(client, "GET", cstLocalhost & "/" + sessionId + "/element/" + elements(ii)(cstE) + "/text")("value")
'        'シート追加
'        Set sh = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
'        'シート名変更
'        sh.Name = stText
    Next ii
    
    
    Set params = New Dictionary
    params.Add "using", "css selector"
    params.Add "value", "#tabpanelTopics1"
    
    Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/element", params)
    elementId = oBuf("value")(cstE)
    
    Set params = New Dictionary
    params.Add "using", "tag name"
    params.Add "value", "a"    '"article" "h1"
    
    Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/element/" + elementId + "/elements", params)
    Dim childElements As Collection
    Set childElements = New Collection
    Set childElements = oBuf("value")
    Dim childId As String
    Dim lchildrenCnt As Long
    lchildrenCnt = childElements.Count
    Debug.Print "tabtopics1における数:" & lchildrenCnt
    For ii = 1 To childElements.Count
        childId = childElements(ii)(cstE)
        stText = SendRequest(client, "GET", cstLocalhost & "/" + sessionId + "/element/" + childId + "/text")("value")
        Debug.Print "tabtopics1:" & ii & ":" & stText
    Next ii
    
    'IT・科学タブをクリック
    SendRequest client, "POST", "http://localhost:4444/session/" + sessionId + "/element/" + elements(7)(cstE) + "/click", New Dictionary
    
    'IT・科学タブパネルにあるarticleについて調査
    Set params = New Dictionary
    params.Add "using", "css selector"
    params.Add "value", "#tabpanelTopics7"
    
    Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/element", params)
    elementId = oBuf("value")(cstE)
    
    Set params = New Dictionary
    params.Add "using", "tag name"
    params.Add "value", "a" '"article" "h1"
    
    Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/element/" + elementId + "/elements", params)
    
    Set childElements = New Collection
    Set childElements = oBuf("value")
    lchildrenCnt = childElements.Count
    Debug.Print "tabtopics7における数:" & lchildrenCnt
    For ii = 1 To childElements.Count
        childId = childElements(ii)(cstE)
        stText = SendRequest(client, "GET", cstLocalhost & "/" + sessionId + "/element/" + childId + "/text")("value")
        Debug.Print "tabtopics7:" & ii & ":" & stText
    Next ii
  
    '終了処理(メモリ解放などの後始末)
    Set params = Nothing
    Set client = Nothing
    Set oBuf = Nothing

End Sub

Private Function SendRequest(ByRef client As Object, method As String, url As String, Optional data As Dictionary = Nothing) As Dictionary
    Dim stBuf As String
    'メソッドに応じてリクエスト送信
    client.Open method, url
    If method = "POST" Or method = "PUT" Then
        client.setRequestHeader "Content-Type", "application/json"
        stBuf = JsonConverter.ConvertToJson(data)
        client.Send stBuf
    Else
        client.Send
    End If

    '送信完了待ち
    Do While client.readyState < 4
        DoEvents
    Loop

    ' レスポンスをDictionaryに変換してリターン
    Dim Json As Object
    Set Json = JsonConverter.ParseJson(client.responseText)
    Set SendRequest = Json
    
    'メモリ解放
    Set Json = Nothing
End Function

それぞれ<a>タグが何個あるか調べたら、どちらも11個でした。<a>タグのtextをデバッグプリントしてみたら、こんな風になりました。

tabtopics1における数:11
tabtopics1:1:残る容疑者2人は8日に送還 比法相
NEW
120
tabtopics1:2:福島の住民帰還へ新区域 閣議決定
95
tabtopics1:3:EU首脳会議にゼレンスキー氏招待
NEW
77
tabtopics1:4:三菱スペースジェット 撤退を発表
524
tabtopics1:5:性同一性障害装い性的暴行か 逮捕
1036
tabtopics1:6:山川穂高「忘れ物」ファン大笑い
NEW
28
tabtopics1:7:やりきった 口癖で国枝氏引退決め
NEW
40
tabtopics1:8:北斗晶に初孫 長男妻が第1子妊娠
384
tabtopics1:9:やり切った
2/7(火) 14:58
共同通信
tabtopics1:10:もっと見る
tabtopics1:11:トピックス一覧
tabtopics7における数:11
tabtopics7:1:トルコ地震巡りSNSにデマ 注意
NEW
tabtopics7:2:いったい何ですか?TW画面に困惑
NEW
228
tabtopics7:3:県防災アプリ 8億円かけDL3000人
NEW
711
tabtopics7:4:もっと見る
tabtopics7:5:ニュース一覧
tabtopics7:6:血液製剤 57年ぶりに輸出再開へ
NEW
153
tabtopics7:7:クジラの死骸 破裂する危険性も
NEW
475
tabtopics7:8:虫好き少女 ピンクのバッタ発見
NEW
122
tabtopics7:9:もっと見る
tabtopics7:10:ニュース一覧
tabtopics7:11:トルコ・シリア地震で「原発事故…
2/7(火) 12:48
朝日新聞デジタル

これだと違いが分からないので、制御できません。

h1タグだとどうかと、同様に調べた結果がこちら。

tabtopics1における数:10
tabtopics1:1:主要 ニュース
tabtopics1:2:残る容疑者2人は8日に送還 比法相
tabtopics1:3:福島の住民帰還へ新区域 閣議決定
tabtopics1:4:EU首脳会議にゼレンスキー氏招待
tabtopics1:5:三菱スペースジェット 撤退を発表
tabtopics1:6:性同一性障害装い性的暴行か 逮捕
tabtopics1:7:山川穂高「忘れ物」ファン大笑い
tabtopics1:8:やりきった 口癖で国枝氏引退決め
tabtopics1:9:北斗晶に初孫 長男妻が第1子妊娠
tabtopics1:10:やり切った
tabtopics7における数:10
tabtopics7:1:IT・科学 ニュース
tabtopics7:2:IT
tabtopics7:3:トルコ地震巡りSNSにデマ 注意
tabtopics7:4:いったい何ですか?TW画面に困惑
tabtopics7:5:県防災アプリ 8億円かけDL3000人
tabtopics7:6:科学
tabtopics7:7:血液製剤 57年ぶりに輸出再開へ
tabtopics7:8:クジラの死骸 破裂する危険性も
tabtopics7:9:虫好き少女 ピンクのバッタ発見
tabtopics7:10:トルコ・シリア地震で「原発事故…

やっぱり同数でした(10)。違いがあるとすれば、「IT」「科学」という単語がある点でしょうか。

<article>というタグが使われていたので、それでも調べてみました。

tabtopics1における数:9
tabtopics1:1:残る容疑者2人は8日に送還 比法相
NEW
186
tabtopics1:2:福島の住民帰還へ新区域 閣議決定
109
tabtopics1:3:EU首脳会議にゼレンスキー氏招待
NEW
96
tabtopics1:4:三菱スペースジェット 撤退を発表
598
tabtopics1:5:性同一性障害装い性的暴行か 逮捕
1130
tabtopics1:6:山川穂高「忘れ物」ファン大笑い
NEW
63
tabtopics1:7:やりきった 口癖で国枝氏引退決め
NEW
50
tabtopics1:8:北斗晶に初孫 長男妻が第1子妊娠
397
tabtopics1:9:やり切った
2/7(火) 14:58
共同通信
tabtopics7における数:9
tabtopics7:1:IT
トルコ地震巡りSNSにデマ 注意
NEW
いったい何ですか?TW画面に困惑
NEW
228
県防災アプリ 8億円かけDL3000人
NEW
711
もっと見る
ニュース一覧
tabtopics7:2:トルコ地震巡りSNSにデマ 注意
NEW
tabtopics7:3:いったい何ですか?TW画面に困惑
NEW
228
tabtopics7:4:県防災アプリ 8億円かけDL3000人
NEW
711
tabtopics7:5:科学
血液製剤 57年ぶりに輸出再開へ
NEW
154
クジラの死骸 破裂する危険性も
NEW
475
虫好き少女 ピンクのバッタ発見
NEW
121
もっと見る
ニュース一覧
tabtopics7:6:血液製剤 57年ぶりに輸出再開へ
NEW
154
tabtopics7:7:クジラの死骸 破裂する危険性も
NEW
475
tabtopics7:8:虫好き少女 ピンクのバッタ発見
NEW
121
tabtopics7:9:トルコ・シリア地震で「原発事故…
2/7(火) 12:48
朝日新聞デジタル

こちらでも同数の9でした。

制御するにあたって、どうやってIT・科学を分けようか考えていたのですが、「IT」「科学」という文字が出現したら制御を変えるしかないようです(今のところ)。

エレメントIDを見つける応用

W3Cによると、次のようなやり方が用意されています。

このうちFind ElementとFind Elementsについては以前書きました。

今回はFind Element From Elementというのと、Find Elements From Elementというのをやろうと思います。

といっても、私が語ることはあまりなく、Find ElementとFind Elementsができているなら、Find Element From Elementも、Find Elements From Elementもその応用にすぎないのですぐに実装できると思います。

エレメントからエレメントを見つける

W3Cを見てもらうのが一番手っ取り早いです。

例えば、Yahoo!のtabtopics1において、最初に出てくる<a>タグのテキストがほしいときはこうします。

Sub FindElementFromElement()
    'Webdriverの起動。Firefoxはデフォルトで4444番ポートを監視
    Shell "C:\drivers\geckodriver.exe", vbMinimizedNoFocus

    'ブラウザ起動パラメータの作成
    Dim params As New Dictionary
    params.Add "capabilities", New Dictionary
    params.Add "desiredCapabilities", Nothing

    'HTTPクライアントの起動
    Dim client As Object
    Set client = CreateObject("MSXML2.ServerXMLHTTP")
    
    'ブラウザ起動
    Const cstLocalhost As String = "http://localhost:4444/session"
    Dim oBuf As Object
    Set oBuf = SendRequest(client, "POST", cstLocalhost, params)
    
    'ブラウザ起動処理の戻り値からSessionIdを取得
    Dim sessionId As String
    sessionId = oBuf("value")("sessionId")

    'URL遷移用のパラメータを定義
    Set params = New Dictionary
    Const cstYahooUrl As String = "https://www.yahoo.co.jp/"
    params.Add "url", cstYahooUrl

    '遷移
    SendRequest client, "POST", cstLocalhost & "/" + sessionId + "/url", params
    
    'tabtopics1を探すためのパラメータを準備
    Set params = New Dictionary
    params.Add "using", "css selector"
    params.Add "value", "#tabpanelTopics1"
    
    'tabtopics1のエレメントIDを`elementId`に控えておく
    Dim elementId As String
    Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/element", params)
    Const cstE As String = "element-6066-11e4-a52e-4f735466cecf"    'この名称がとても長いので可読性を上げるためにコンスト値とする。
    elementId = oBuf("value")(cstE)
    
    'デバグ用に今とってきたエレメントIDのテキストをとってきておく
    Dim stText As String
    stText = SendRequest(client, "GET", cstLocalhost & "/" + sessionId + "/element/" + elementId + "/text")("value")
    Debug.Print "tabtopics1:" & stText
    
    'Find Element From Element
    'tabtopics1のエレメントIDから配下にあるaタグの要素を見つけ出す
    
    Set params = New Dictionary
    params.Add "using", "tag name"
    params.Add "value", "a"
    
    Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/element/" + elementId + "/element", params)
    Dim childId As String
    childId = oBuf("value")(cstE)
    
    'デバグ用に今とってきたエレメントIDのテキストをとってきておく
    stText = SendRequest(client, "GET", cstLocalhost & "/" + sessionId + "/element/" + childId + "/text")("value")
    Debug.Print "最初のaタグ:" & stText
  
    '終了処理(メモリ解放などの後始末)
    Set params = Nothing
    Set client = Nothing
    Set oBuf = Nothing

End Sub

↑SendRequestサブは省略してあります。前記事とか、元ネタのサイトを見てください。

デバッグした結果はこんな感じです。

tabtopics1:主要 ニュース
2/7(火) 15:37更新
残る容疑者2人は8日に送還 比法相
NEW
321
EU首脳会議にゼレンスキー氏招待
121
従業員の転退職で倒産 3年ぶり増
NEW
174
父親殺害 元医師に懲役13年の判決
NEW
61
性同一性障害装い性的暴行か 逮捕
1431
山川穂高「忘れ物」ファン大笑い
NEW
136
やりきった 口癖で国枝氏引退決め
67
北斗晶に初孫 長男妻が第1子妊娠
451
やり切った
2/7(火) 14:58
共同通信
もっと見る
トピックス一覧
最初のaタグ:残る容疑者2人は8日に送還 比法相
NEW
321

おおもととなるエレメントが、検索対象のエレメントを複数持つ場合、このFind Element From Elementはあまり使えないです。

もっぱら次のFind Elements From Elementを使うことになると思います。

エレメントから複数のエレメントを見つける

先ほどとの違いは最後のsがつくことです。

elementでなくelementsとなっています。

また戻り値は複数の要素となります。VBAの場合はコレクションを用意しておかないと取り出せません。

実装はこんな風になります(その部分だけ)。

    Set params = New Dictionary
    params.Add "using", "tag name"
    params.Add "value", "article" '"h1"
    
    Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/element/" + elementId + "/elements", params)
    Dim childElements As Collection
    Set childElements = New Collection
    Set childElements = oBuf("value")
    Dim childId As String
    Dim lchildrenCnt As Long
    lchildrenCnt = childElements.Count

実は↑このコードは、本日の記事冒頭でお示ししたコードの一部です。

全体像はそちらで確認してください。

まとめ

Find Elements From Elementについて紹介しました。

結局本日も最終目的であるリンクをワークシートに貼るところまでいきませんでした。

さらに続きます。

前の記事

【ExcelVBA】Web情報でシートを作成しリンクを貼る【Seleniumなしでスクレイピング】【Firefox】Part1 2023.02.07
次の記事

【ExcelVBA】Web情報でシートを作成しリンクを貼る【Seleniumなしでスクレイピング】【Firefox】Part3 2023.02.09

【ExcelVBA】Web情報でシートを作成しリンクを貼る【Seleniumなしでスクレイピング】【Firefox】Part2

tabtopics7における問題点

エレメントIDを見つける応用

エレメントからエレメントを見つける

エレメントから複数のエレメントを見つける

まとめ

【ExcelVBA】Web情報でシートを作成しリンクを貼る【Seleniumなしでスクレイピング】【Firefox】Part1 2023.02.07

【ExcelVBA】Web情報でシートを作成しリンクを貼る【Seleniumなしでスクレイピング】【Firefox】Part3 2023.02.09

RANKING

照合省略と17条付記

【Mac】マウス操作を自動化するツール【Automator】

【Excel】PowerQueryで正規表現を使う方法【M式言語】

ブラウザもSeleniumも使わずExcelVBAでスクレイピング

フォルダ配下(サブフォルダも)ファイル一覧を取得するには【CMD】【ExcelVBA】

【外国人技能実習生】国民年金の免除申請について【入国後講習中】

VBAで開いたフォルダをVBAで閉じるには

【VBA】クラスモジュールの使いどころーコレクションで使う―

深夜労働を1日しただけでも健康診断は半年に1回なのか

【SeleniumBasic】地図の距離と時間を取得する【Excel】