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

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
    
    'tabtopicsを探すためのパラメータを準備
    Set params = New Dictionary
    params.Add "using", "css selector"
    params.Add "value", "[role=""tab""]"
    
    'tabtopicsのエレメント群を取得
    Dim elementId As String
    Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/elements", params)
    
    'エレメント群が格納されているコレクションを取得するための変数を用意
    Dim tabtopics As Collection
    Set tabtopics = New Collection
    Set tabtopics = oBuf("value")
    
    'tabtopicsの件数
    Dim ltabTopicsCnt As Long
    ltabTopicsCnt = tabtopics.Count
    
    'エレメントIDを示すキー文字列
    Const cstE As String = "element-6066-11e4-a52e-4f735466cecf"
    
    'ループ内で使う変数の宣言
    Dim ii As Long, jj As Long, kk As Long, mm As Long
    
    'ワークシート操作関連の変数
    Dim lRow As Long
    Dim stText As String, stId As String
    Dim stShName As String
    Dim Bk As Workbook, tSh As Worksheet
    Set Bk = ThisWorkbook
    
    'articleタグ用
    Dim artElements As Collection
    Dim artId As String
    Dim lartCnt As Long
    
    'ulタグ用
    Dim ulElements As Collection
    Dim ulId As String
    Dim lulCnt As Long
    
    'aタグ用
    Dim aElements As Collection
    Dim aId As String
    Dim laCnt As Long
    
    For ii = 1 To ltabTopicsCnt
        
        'tabtopicsのタブ名を取得(例：ニュース、経済、エンタメ、スポーツ、国内、国際、IT・科学、地域
        elementId = tabtopics(ii)(cstE)
        stShName = SendRequest(client, "GET", cstLocalhost & "/" + sessionId + "/element/" + elementId + "/text")("value")
        
        'シートを追加しリネーム
        If IsExistThatsName(stShName) = True Then
            'すでに同名のシートが存在する
            Set tSh = Bk.Worksheets(stShName)
            'シートのセルの内容をクリアコンテンツする
            tSh.Cells.ClearContents
        Else
            'シート追加
            Set tSh = Bk.Worksheets.Add(After:=Bk.Worksheets(Bk.Worksheets.Count))
            'シート名変更
            tSh.Name = stShName
        End If
        
        'tabをクリックする(1以外)
        If ii = 1 Then
            'Nothing
        Else
            SendRequest client, "POST", cstLocalhost & "/" + sessionId + "/element/" + elementId + "/click", New Dictionary
        End If
        
        'シートのセルに書き込むための行番号を初期化
        lRow = 2
        
        'tabtopicsのtabごとに記事とリンクを把握する
        '記事一覧のことをtabpaneltopicsと言う。

        'tabpaneltopicsを取得するためのパラメータを作成
        Set params = New Dictionary
        params.Add "using", "css selector"
        params.Add "value", "#tabpanelTopics" & ii
        
        'tabpaneltopicsのエレメントを取得
        Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/element", params)
        stId = oBuf("value")(cstE)
        
        'tabpaneltopicsの下にある記事一つ一つを取得する
        
        'tabpaneltopicsの下にあるulを取得する
        Set params = New Dictionary
        params.Add "using", "tag name"
        params.Add "value", "ul"
        Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/element/" + stId + "/elements", params)
        Set ulElements = New Collection
        Set ulElements = oBuf("value")
        'ulの件数
        lulCnt = ulElements.Count
        
       'ulの配下にあるarticleタグを探す
        For jj = 1 To lulCnt
                    
            'ulタグのエレメントIDを取得
            ulId = ulElements(jj)(cstE)
            
            'articleを取得する
            Set params = New Dictionary
            params.Add "using", "tag name"
            params.Add "value", "article"
            Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/element/" + ulId + "/elements", params)
            Set artElements = New Collection
            Set artElements = oBuf("value")
            'articleの件数
            lartCnt = artElements.Count
            If ii = 7 Then
                'IT・科学のときだけ
                If jj = 1 And lartCnt > 0 Then
                    With tSh.Cells(lRow, 2)
                        'IT
                        .Value = "IT"
                        .ClearHyperlinks
                        With .Font
                            .Underline = xlUnderlineStyleNone
                            .ColorIndex = xlAutomatic
                        End With
                    End With
                    lRow = lRow + 1
                ElseIf jj = 2 And lartCnt = 0 Then
                    With tSh.Cells(lRow, 2)
                        '科学
                        .Value = "科学"
                        .ClearHyperlinks
                        With .Font
                            .Underline = xlUnderlineStyleNone
                            .ColorIndex = xlAutomatic
                        End With
                    End With
                    lRow = lRow + 1
                End If
            End If
                    
            'articleの配下にあるaタグを探して取得する
            For kk = 1 To lartCnt
                'articleタグのエレメントIDを取得
                artId = artElements(kk)(cstE)
                
                'aタグを取得
                Set params = New Dictionary
                params.Add "using", "tag name"
                params.Add "value", "a"
                Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/element/" + artId + "/elements", params)
                Set aElements = New Collection
                Set aElements = oBuf("value")
                laCnt = aElements.Count
                
                For mm = 1 To laCnt
                    
                    'aタグのエレメントIDを取得
                    aId = aElements(mm)(cstE)
                    
                    'aタグの中にあるh1タグを取得
                    Set params = New Dictionary
                    params.Add "using", "tag name"
                    params.Add "value", "h1"
                    Set oBuf = SendRequest(client, "POST", cstLocalhost & "/" + sessionId + "/element/" + aId + "/element", params)
                    
                    'h1タグのエレメントIDを取得
                    stId = oBuf("value")(cstE)
                    
                    'h1タグのテキストを取得
                    stText = SendRequest(client, "GET", cstLocalhost & "/" + sessionId + "/element/" + stId + "/text")("value")
                    'セルに書き込む
                    tSh.Cells(lRow, 2).Value = stText
                    
                    'リンクアドレスを取得
                    stText = SendRequest(client, "GET", cstLocalhost & "/" + sessionId + "/element/" + aId + "/property/href")("value")
                    'ハイパーリンクを設定
                    tSh.Hyperlinks.Add Anchor:=tSh.Cells(lRow, 2), Address:=stText
                    
                    '文字折り返しなしに設定
                    tSh.Cells(lRow, 2).WrapText = False
                    
                    '行番号操作用変数インクリメント
                    lRow = lRow + 1
                Next mm
            Next kk
        Next jj
    Next ii
    
    '終了処理
    EndProc
    
    'メモリ解放などの後始末
    Set params = Nothing
    Set client = Nothing
    Set oBuf = Nothing
    Set tabtopics = Nothing: Set artElements = Nothing
    Set ulElements = Nothing: Set aElements = Nothing
    Set Bk = Nothing: Set tSh = 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

'同一シート名が存在しないか調査
'存在するならTrueを返す
Private Function IsExistThatsName(ByVal stName As String) As Boolean
    Dim sh As Worksheet
    Dim Flg As Boolean
    
    Flg = False
    
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name = stName Then
            Flg = True
            Exit For
        End If
    Next sh
    
   IsExistThatsName = Flg
    
End Function

'開いているWebdriverを終了させる
Private Sub EndProc()
    Dim Wd As Object
    
    Set Wd = CreateObject("Word.Application")
    If Wd.Tasks.Exists("geckodriver.exe") Then
        Wd.Tasks("geckodriver.exe").Close
    End If
    Wd.Quit
    Set Wd = Nothing
    
End Sub