Go to Qiita Advent Calendar 2024 Top
LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 3 years have passed since last update.

@gaku0202(M O)

VBA scraping

Last updated at Posted at 2021-08-20

image.png
■開発メモ
参考サイト https://note.com/teihen_escape/n/n40e672b1c97f
Selenium C:\Users\revolvesys\AppData\Local\SeleniumBasic
ChromeDriver C:\Users\revolvesys\Desktop\chromedriver_win32

Driver.PageSource ソース表示
Driver.SwitchToNextWindow 次のタブ
Driver.SwitchToPreviousWindow 前のタブ
Driver.SwitchToParentFrame 元のFrameに戻る
Driver.SwitchToFrame "Frame名" Frame切り替え（切り替え後は元のFrameに戻らないと他のFrameに切り替えられない）

main module
Option Explicit

    '##### 変数宣言 #####

    '設定シートの設定格納用
    Public strOutputPath        As String   '出力先パス格納用
    Public strUrl               As String   'URL格納用
    Public strId                As String   'ID格納用
    Public strPassword          As String   'PW格納用
    Public strSearchWord()      As String   '検索ワード格納用
    
    'その他変数
    Public strMsgErr            As String    'エラー格納用
    Public blnFlgErr            As Boolean   'エラー時フラグ
    Public strBuf               As String    'バッファ用
    Public strErr               As String    'エラーメッセージ格納用
    Public blnFlgGoNextPage     As Boolean   '次ページフラグ
    
    
    '##### 定数宣言 #####
    
    'シート名
    Public Const strSHT_NAME_SETTEI         As String = "設定"
    Public Const strRNG_OUT_PATH            As String = "C3"
    Public Const strRNG_URL                 As String = "C4"
    Public Const strRNG_ID                  As String = "C5"
    Public Const strRNG_PW                  As String = "C6"
    Public Const strCOL_START_SEARCH_WORD   As String = "B"
    Public Const strCOL_GET_SEARCH_WORD     As String = "C"
    Public Const lngROW_START_SEARCH_WORD   As Long = 10
    
    'メッセージ系
    Public Const strMSG_INFO_END            As String = "処理が完了しました。"
    Public Const strMSG_ERR_CHK_EMPTY       As String = "以下項目が空白です。" & vbCrLf & "値を入力し再実行して下さい。"
    Public Const strMSG_OUT_PATH            As String = "出力先"
    Public Const strMSG_URL                 As String = "検索先URL"
    Public Const strMSG_ID                  As String = "ID"
    Public Const strMSG_PASSWORD            As String = "PASSWORD"
    Public Const strMSG_SEARCH_WORD         As String = "検索Word"
    Public Const strMSG_ERR_UNEXPECT        As String = "予期しないエラーが発生しました。"
    Public Const strERR_NUM                 As String = "エラー番号："
    Public Const strERR_DESCRIPTION         As String = "エラー内容："
    Public Const strERR_GET_SETTEI          As String = "設定処理で以下エラーが発生しました。"
    Public Const strERR_SCRAPING_1          As String = "スクレイピング処理（ログイン～ワード入力）で以下エラーが発生しました。"
    Public Const strERR_SCRAPING_2          As String = "スクレイピング処理（ワード検索～全文取得）で以下エラーが発生しました。"
    Public Const strERR_SCRAPING_3          As String = "スクレイピング処理（次へ処理）で以下エラーが発生しました。"
    Public Const strERR_TYUUDAN             As String = "処理を中止します。"
    Public Const strMSG_SHOW_KENSUU_1       As String = "検索結果は「"
    Public Const strMSG_SHOW_KENSUU_2       As String = "」件です。"
    Public Const strMSG_SHOW_KENSUU_3       As String = "処理を続行しますか？"
    
    
    'その他定数
    Public Const strEMPTY               As String = ""  '空白
    
    
'###############################################
'#  処理概要：メイン処理
'#　引数　　：なし
'#  戻り値　：なし
'#
'###############################################
Sub subMain()
    
    '##### 変数宣言 #####
    Dim Driver  As New ChromeDriver
    Dim myBy    As New By
    
    Debug.Print "START: " & Time
    
    On Error GoTo Err_Exit

    '##### 初期設定 #####
    
    Call fncStopConfig  '無駄な設定を止める
    strMsgErr = strEMPTY
    blnFlgErr = False
    ReDim Preserve strSearchWord(0)
    strSearchWord(0) = strEMPTY
    blnFlgGoNextPage = True
    
    
    '##### 設定値取得 #####
    
    strBuf = fncGetSettei()
    If Not strBuf = strEMPTY Then
        GoTo Err_Exit
    End If
    
    
    '##### スクレイピング処理 #####
    
    'スクレイピング（ログイン～検索）処理
    strBuf = fncScraping1(Driver)
    If Not strBuf = strEMPTY Then
        GoTo Err_Exit
    End If
    
Next_Page:

    'スクレイピング（全文取得～Word出力）処理
    strBuf = fncScraping2(Driver)
    If Not strBuf = strEMPTY Then
        GoTo Err_Exit
    End If
    
    '次のページボタン
    strBuf = fncScraping2(Driver)
    If Not strBuf = strEMPTY Then
        GoTo Err_Exit
    End If
    If blnFlgGoNextPage Then
        GoTo Next_Page
    End If
    
    GoTo Finaly

Err_Exit:
    
    'エラーメッセージ表示
    If Err.Number = 0 Then
        MsgBox strMsgErr, vbExclamation
    Else
        MsgBox strMSG_ERR_UNEXPECT & vbCrLf & strERR_NUM & Err.Number & vbCrLf & strERR_DESCRIPTION & Err.Description, vbExclamation
    End If

    blnFlgErr = True

Finaly:

    '##### 終了処理 #####

    Call fncReStartCongig
    Driver.Close
    Set Driver = Nothing
    
    Debug.Print "END  : " & Time
    
    If Not blnFlgErr Then
        '正常終了メッセージ表示
        MsgBox strMSG_INFO_END, vbInformation
    End If

End Sub

'###############################################
'#  処理概要：設定値取得処理
'#　引数　　：なし
'#  戻り値　：strMsgErr:エラーがあった場合、エラー文言を格納
'#
'###############################################
Private Function fncGetSettei() As String
    
    '変数宣言
    Dim lngCntRow As Long
    Dim lngCntWord As Long
    
    '初期設定
    lngCntRow = lngROW_START_SEARCH_WORD
    lngCntWord = 0
    
    On Error GoTo Err_Exit
    
    '設定値取得
    strOutputPath = ThisWorkbook.Sheets(strSHT_NAME_SETTEI).Range(strRNG_OUT_PATH)
    strUrl = ThisWorkbook.Sheets(strSHT_NAME_SETTEI).Range(strRNG_URL)
    strId = ThisWorkbook.Sheets(strSHT_NAME_SETTEI).Range(strRNG_ID)
    strPassword = ThisWorkbook.Sheets(strSHT_NAME_SETTEI).Range(strRNG_PW)
    
    Do Until ThisWorkbook.Sheets(strSHT_NAME_SETTEI).Range(strCOL_START_SEARCH_WORD & CStr(lngCntRow)) = strEMPTY
        strBuf = ThisWorkbook.Sheets(strSHT_NAME_SETTEI).Range(strCOL_GET_SEARCH_WORD & CStr(lngCntRow))
        If Not strBuf = strEMPTY Then
            ReDim Preserve strSearchWord(lngCntWord)
            strSearchWord(lngCntWord) = strBuf
            lngCntWord = lngCntWord + 1
        End If
        lngCntRow = lngCntRow + 1
    Loop
    strBuf = strEMPTY
    
    '空白チェック
    strBuf = fncCheckEmpty(strOutputPath)
    If Not strBuf = strEMPTY Then
        strMsgErr = strBuf & vbCrLf & strMSG_OUT_PATH
        GoTo Err_Exit
    End If
    strBuf = strEMPTY
    
    strBuf = fncCheckEmpty(strUrl)
    If Not strBuf = strEMPTY Then
        strMsgErr = strBuf & vbCrLf & strMSG_URL
        GoTo Err_Exit
    End If
    strBuf = strEMPTY
    
    strBuf = fncCheckEmpty(strId)
    If Not strBuf = strEMPTY Then
        strMsgErr = strBuf & vbCrLf & strMSG_ID
        GoTo Err_Exit
    End If
    strBuf = strEMPTY

    strBuf = fncCheckEmpty(strPassword)
    If Not strBuf = strEMPTY Then
        strMsgErr = strBuf & vbCrLf & strMSG_URL
        GoTo Err_Exit
    End If
    strBuf = strEMPTY
    
    If lngCntWord = 0 Then
        strMsgErr = strBuf & vbCrLf & strMSG_SEARCH_WORD
        GoTo Err_Exit
    End If
    
    GoTo Finaly

Err_Exit:

    If strMsgErr = strEMPTY Then
        strMsgErr = strERR_GET_SETTEI & vbCrLf & strMSG_ERR_UNEXPECT & vbCrLf & strERR_NUM & Err.Number & vbCrLf & strERR_DESCRIPTION & Err.Description
    End If
    
    fncGetSettei = strMsgErr

Finaly:
        
End Function

'###############################################
'#  処理概要：スクレイピング（ログイン～検索）処理
'#　引数　　：Driver（クロームの処理）
'#  戻り値　：strMsgErr:エラーがあった場合、エラー文言を格納
'#
'###############################################
Private Function fncScraping1(ByVal Driver As ChromeDriver) As String
    
    '##### 変数宣言 #####
    Dim varWord             As Variant
    Dim lngCntLoop          As Long
    Dim rc                  As VbMsgBoxResult
    
    On Error GoTo Err_Exit

    lngCntLoop = 1
    
    Driver.Start "chrome"
    Driver.Get strUrl
    Driver.Wait 10000
    
    'ログインボタン押下
    Driver.FindElementById("LoginAccount").SendKeys strId
    Driver.FindElementById("Password").SendKeys strPassword
    Driver.FindElementById("ImageButton1").Click
    Driver.Wait 5000
    
    'LEX/DBインターネット　リンク押下
    Driver.FindElementByXPath("//*[@id=""A0""]").Click
    Driver.Wait 3000
    'タブ移動
    Driver.SwitchToNextWindow
    '判例総合検索　リンク押下
    Driver.FindElementByClass("btnlink14pb").Click
    Driver.Wait 3000

    'Frame切り替え（このページは2つのViewで構成されているため）
    Driver.SwitchToFrame "contents"
    
    '検索objWord入力(Max5個想定）
    For Each varWord In strSearchWord
        If lngCntLoop = 1 Then
            Driver.FindElementById("InputFreeKeyword_Control_KEYWORD00").SendKeys varWord
        ElseIf lngCntLoop = 2 Then
            Driver.FindElementById("InputFreeKeyword_Control_KEYWORD05").SendKeys varWord
        ElseIf lngCntLoop = 3 Then
            Driver.FindElementById("InputFreeKeyword_Control_KEYWORD10").SendKeys varWord
        ElseIf lngCntLoop = 4 Then
            Driver.FindElementById("InputFreeKeyword_Control_KEYWORD15").SendKeys varWord
        ElseIf lngCntLoop = 5 Then
            Driver.FindElementById("InputFreeKeyword_Control_KEYWORD20").SendKeys varWord
        End If
        
        lngCntLoop = lngCntLoop + 1
        
    Next varWord

    'Frame切り替え(元のFrameに戻ってから切り替え)（このページは2つのViewで構成されているため）
    Driver.SwitchToParentFrame
    Driver.SwitchToFrame "head"
    
    '検索ボタン押下
    Driver.FindElementById("SearchHyperLink").Click

    '##### 件数表示 #####
    
    'Frame切り替え(元のFrameに戻ってから切り替え)（このページは2つのViewで構成されているため）
    Driver.SwitchToParentFrame
    Driver.SwitchToFrame "header"
    
    '検索結果件数取得
    strBuf = Driver.FindElementByClass("Kensuu").Text

    rc = MsgBox(strMSG_SHOW_KENSUU_1 & strBuf & strMSG_SHOW_KENSUU_2 & vbCrLf & strMSG_SHOW_KENSUU_3, vbYesNo + vbQuestion)
    If Not rc = vbYes Then
        strMsgErr = strERR_TYUUDAN
        GoTo Err_Exit
    End If
    
    GoTo Finaly

Err_Exit:

    If strMsgErr = strEMPTY Then
        strMsgErr = strERR_SCRAPING_1 & vbCrLf & strMSG_ERR_UNEXPECT & vbCrLf & strERR_NUM & Err.Number & vbCrLf & strERR_DESCRIPTION & Err.Description
    End If
    
    fncScraping1 = strMsgErr

Finaly:
        
End Function

'###############################################
'#  処理概要：スクレイピング（全文取得～Word出力）処理
'#　引数　　：Driver（クロームの処理）
'#  戻り値　：strMsgErr:エラーがあった場合、エラー文言を格納
'#
'###############################################
Private Function fncScraping2(ByVal Driver As ChromeDriver) As String
    
    '##### 変数宣言 #####
    Dim elements            As WebElements
    Dim lngCntElem          As Long
    Dim strFileName()       As String
    Dim lngCntFileName      As Long
    Dim lngCntFileNameSplit As Long
    Dim lngCntZenbun        As Long
    Dim objWord             As New Word.Application
    Dim docWord             As Word.Document
    Dim strSavePath         As String
    
    On Error GoTo Err_Exit
    
    '初期化
    lngCntFileName = 0
    lngCntFileNameSplit = 1
    lngCntZenbun = 0
    strBuf = strEMPTY
    ReDim Preserve strFileName(lngCntFileName)
    strFileName(lngCntFileName) = strEMPTY
    
    '##### 裁判所名、日付取得 #####
    
    'Frame切り替え(元のFrameに戻ってから切り替え)（このページは2つのViewで構成されているため）
    Driver.SwitchToParentFrame
    Driver.SwitchToFrame "main"
    
    Set elements = Driver.FindElementsByCss(".ListLow3")
    For lngCntElem = 1 To elements.Count
        strBuf = strBuf & "_" & Trim(elements.Item(lngCntElem).Text)
        lngCntFileNameSplit = lngCntFileNameSplit + 1
        
        '6個で分割する（ファイル名作成のため）
        If lngCntFileNameSplit > 6 Then
            ReDim Preserve strFileName(lngCntFileName)
            strFileName(lngCntFileName) = Mid(strBuf, 2, Len(strBuf))
            lngCntFileName = lngCntFileName + 1
            strBuf = strEMPTY
            lngCntFileNameSplit = 1
        End If
        
    Next
    
    Dim i As Variant
    
    Debug.Print "############################################################"
    For Each i In strFileName
        Debug.Print i
    Next i
    Debug.Print "############################################################"
    
    '##### 全文取得→Word出力 #####
    
    Set elements = Driver.FindElementsByTag("a")
    
    For lngCntElem = 1 To elements.Count
    
        strBuf = elements.Item(lngCntElem).Attribute("href")
        
        If InStr(strBuf, "ShowZenbun") Then
            
            '全文URLクリック
            elements.Item(lngCntElem).Click
            
            'Frame切り替え(元のFrameに戻ってから切り替え)（このページは2つのViewで構成されているため）
            Driver.SwitchToParentFrame
            Driver.SwitchToFrame "main"
            
            Debug.Print strFileName(lngCntZenbun) & ".docx"
            'word出力処理
'            strSavePath = strOutputPath & "\" & strFileName(lngCntZenbun) & ".docx"
            lngCntZenbun = lngCntZenbun + 1
'            Set docWord = objWord.Documents.Add
'            strBuf = Driver.FindElementByTag("body").Text
'            With docWord
'            .ActiveWindow.Selection.TypeText Text:=strBuf
'            .SaveAs2 strSavePath
'            .Close
'            End With
'            Set docWord = Nothing
'            objWord.Quit
'            Set objWord = Nothing
'            Application.CutCopyMode = False
            
            '前ページに戻る
            Driver.GoBack
        End If
        
        'タグを再取得（再取得しないとエラーになる）
        Set elements = Nothing
        Driver.SwitchToParentFrame
        Driver.SwitchToFrame "main"
        Set elements = Driver.FindElementsByTag("a")
        
    Next

    GoTo Finaly

Err_Exit:

    If strMsgErr = strEMPTY Then
        strMsgErr = strERR_SCRAPING_2 & vbCrLf & strMSG_ERR_UNEXPECT & vbCrLf & strERR_NUM & Err.Number & vbCrLf & strERR_DESCRIPTION & Err.Description
    End If
    
    fncScraping2 = strMsgErr

Finaly:

    Erase strFileName
    
End Function

'###############################################
'#  処理概要：スクレイピング（全文取得～Word出力）処理
'#　引数　　：Driver（クロームの処理）
'#  戻り値　：strMsgErr:エラーがあった場合、エラー文言を格納
'#
'###############################################
Private Function fncScrapingGoNextPage(ByVal Driver As ChromeDriver) As String
    
    On Error Resume Next
    
    'Frame切り替え(元のFrameに戻ってから切り替え)（このページは2つのViewで構成されているため）
    Driver.SwitchToParentFrame
    Driver.SwitchToFrame "header"
    
    If Not Err.Number = 0 Then
        GoTo Err_Exit
    End If
    
    '次へクリック
    Driver.FindElementById("GoNextHyperLink").Click
    
    'クリック処理でエラーの場合は次へページフラグを切る
    If Not Err.Number = 0 Then
        blnFlgGoNextPage = False
        GoTo Finaly
    End If
    
    GoTo Finaly

Err_Exit:

    If strMsgErr = strEMPTY Then
        strMsgErr = strERR_SCRAPING_3 & vbCrLf & strMSG_ERR_UNEXPECT & vbCrLf & strERR_NUM & Err.Number & vbCrLf & strERR_DESCRIPTION & Err.Description
    End If
    
    fncScrapingGoNextPage = strMsgErr

Finaly:
    
End Function

common module
Option Explicit

'###############################################
'#  処理概要：無駄な設定を止める
'#　引数　　：なし
'#  戻り値　：なし
'#
'###############################################
Public Function fncStopConfig()

    With Application
        .Calculation = xlCalculationManual  '自動計算
        .EnableEvents = False               'イベント
        .ScreenUpdating = False             '画面更新
    End With

End Function

'###############################################
'#  処理概要：無駄な設定を初期状態に戻す
'#　引数　　：なし
'#  戻り値　：なし
'#
'###############################################
Public Function fncReStartCongig()

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Function

'###############################################
'#  処理概要：空白チェック
'#　引数　　：strValue
'#  戻り値　：空白ではないの場合　　　　→　TRUE
'#　　　　　　空白である場合　→　FALSE
'#
'###############################################
Public Function fncCheckEmpty(ByVal strValue As String) As String

    If strValue = strEMPTY Then
        fncCheckEmpty = strMSG_ERR_CHK_EMPTY
        Exit Function
    End If

End Function
0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?