【ソースだけ】SeleniumBasicの使い勝手を良くするモジュール

このモジュールを入れておけばSeleniumBasicを使ったプログラム作りが捗るはず!

と言っても個別で紹介したソースをひとまとめにしたコピペ用なイメージなのでそれぞれの使い方とかソースは各リンクからどうぞ

何か思いついたらどんどん追加していきます!

Option Explicit
Option Base 0
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
                        (ByVal pCaller As Long, _
                         ByVal szURL As String, _
                         ByVal szFileName As String, _
                         ByVal dwReserved As Long, _
                         ByVal lpfnCB As Long) As Long
 
Private strUrl As String
Private ChromeDriverPath As String
 
Private driver As Selenium.ChromeDriver
Private Keys As New Selenium.Keys
Private objFso As Object ' Scripting.FileSystemObject '--- 「Microsoft Scripting Runtime」の参照設定
Private objDic As Object ' Scripting.Dictionary
Private objReg As Object ' VBScript_RegExp_55.RegExp '--- 「Microsoft VBScript Regular Expressions 5.5」の参照設定
Private objMat As Object 'MatchCollection '--- 「Microsoft VBScript Regular Expressions 5.5」の参照設定
Private xmlhttp As Object ' MSXML2.XMLHTTP60 '--- 「Microsoft XML v6.0」の参照設定
 
Private Const CheckFolder As String = "drivercheck"
Private Const zipFile As String = "driver.zip"

Private profile As String
Private i As Long, lp As Long
Private Const defWaitMS As Long = 500
Private Const LpWaitCnt As Long = 30
Public Function SafeGet(ByVal driver As Selenium.ChromeDriver, target_url As String, Optional check_mode As Long = 0) As Boolean
'====================================================================================================
'Getがエラーになりがちだから慎重にGetをする
'※リダイレクトページだと上手くいかない・・・
'====================================================================================================
With driver
    On Error Resume Next
    .Get target_url
    If check_mode = 0 Then
        Do
            If .Url = target_url Then
                .Wait 1000
                Exit Do
            End If
        Loop
    Else
        .Wait 1000
    End If
    On Error GoTo 0
End With
End Function
Public Function SeleniumOpen(ByRef driver As Selenium.ChromeDriver) As Boolean
'====================================================================================================
'普通にChromeを立ち上げて後からChromeDriverで掴みに行く
'※添付フォルダにプロファイル情報を置く
'====================================================================================================
Select Case True
    Case Len(Environ("TMP")) > 0
        profile = Environ("TMP") & "\userdata"
    Case Len(Environ("TEMP"))
        profile = Environ("TEMP") & "\userdata"
    Case Else
        profile = ThisWorkbook.Path & "\userdata"
End Select
On Error Resume Next '---プロセスファイルを掴んでいる場合はスキップする
With CreateObject("Scripting.FileSystemObject")
    If .FolderExists(profile) = True Then '---一時プロファイル用にフォルダがあれば削除
        .DeleteFolder profile
    End If
    .CreateFolder profile '---一時プロファイル用にフォルダを作る
End With
CreateObject("WScript.Shell").Run ("chrome.exe --remote-debugging-port=9222 --user-data-dir=""" & profile & "")
On Error GoTo 0
driver.SetCapability "debuggerAddress", "127.0.0.1:9222"
End Function
Public Function SeleniumClose(ByRef driver As Selenium.ChromeDriver, Optional DeleteProfile As Boolean = True) As Boolean
'====================================================================================================
'Chromeを落としつつ一時プロファイルフォルダを削除する
'====================================================================================================
On Error Resume Next
driver.Close
driver.Quit

If DeleteProfile = True Then
    With CreateObject("Scripting.FileSystemObject")
        If .FolderExists(profile) = True Then
            .DeleteFolder profile
        End If
    End With
End If
On Error GoTo 0
Set driver = Nothing
End Function
Public Function ViewCheck(ByVal driver As Selenium.ChromeDriver, ByVal By As Selenium.By, Optional CheckMode As Long = 0, Optional ByVal Index As Long = 1) As Boolean
'====================================================================================================
'画面上に指定した要素があるか確認する
'====================================================================================================
Dim j As Long
For j = 1 To 3
    If driver.FindElements(By).Count > 0 Then
        ViewCheck = ViewCheckElm(driver, driver.FindElements(By)(Index), CheckMode)
        Exit For
    Else
        ViewCheck = False
    End If
Next
End Function
Public Function ViewCheckElm(ByVal driver As Selenium.ChromeDriver, element As Selenium.WebElement, Optional CheckMode As Long = 0) As Boolean
'==============================
'CheckMode
'0:活性化しているかまで
'1:画面上に表示されているかまで
'2:DOMに存在しているかまで
'==============================
On Error GoTo ErrEnd
With element
    For lp = 1 To LpWaitCnt '---要素が存在するかチェック※待機秒数はLpWaitCntで指定
        If .IsPresent = True Then
            Exit For
        Else
            DoEvents
            driver.Wait 1000 '---1秒待機
        End If
    Next
    If .IsPresent = False Then '---ループを抜けても要素が見つからないと言うことは失敗扱い
        ViewCheckElm = False
        Exit Function
    End If
    
    If CheckMode <= 1 Then
        For lp = 1 To LpWaitCnt '---要素が見えているかチェック※待機秒数はLpWaitCntで指定
            If .IsDisplayed = True Then
                Exit For
            Else
                DoEvents
                driver.Wait 1000 '---1秒待機
            End If
        Next
        If .IsDisplayed = False Then '---ループを抜けても見つからないと言うことは失敗扱い
            ViewCheckElm = False
            Exit Function
        End If
    End If
    
    If CheckMode <= 2 Then
        If .IsEnabled = False Then '---活性化しているかチェック
            ViewCheckElm = False
            Exit Function
        End If
    End If
End With
ViewCheckElm = True
On Error GoTo 0
Exit Function
ErrEnd:
ViewCheckElm = False
Debug.Print Err.Description
End Function
Public Function InputText(ByVal driver As Selenium.ChromeDriver, ByVal By As Selenium.By, ByVal str As String, Optional ByVal Index As Long = 1, Optional WaitMS = defWaitMS) As Boolean
'====================================================================================================
'InputTextElmの亜種
'====================================================================================================
Dim j As Long
For j = 1 To 3
    If driver.FindElements(By).Count > 0 Then
        InputText = InputTextElm(driver, driver.FindElements(By)(Index), str, WaitMS)
        Exit For
    Else
        InputText = False
    End If
Next
End Function
Public Function InputTextElm(ByVal driver As Selenium.ChromeDriver, element As Selenium.WebElement, ByVal str As String, Optional WaitMS = defWaitMS) As Boolean
'====================================================================================================
'文字入力を色々考慮しながらやる
'====================================================================================================
On Error GoTo ErrEnd
With element
    For lp = 1 To LpWaitCnt '---要素が存在するかチェック※待機秒数はLpWaitCntで指定
        driver.Timeouts.ImplicitWait = 30
        If .IsPresent = True Then
            Exit For
        Else
            DoEvents
            driver.Wait 1000 '---1秒待機
        End If
    Next
    If .IsPresent = False Then '---ループを抜けても要素が見つからないと言うことは失敗扱い
        InputTextElm = False
        Exit Function
    End If
    
    For lp = 1 To LpWaitCnt '---要素が見えているかチェック※待機秒数はLpWaitCntで指定
        If .IsDisplayed = True Then
            Exit For
        Else
            DoEvents
            driver.Wait 1000 '---1秒待機
        End If
    Next
    If .IsDisplayed = False Then '---ループを抜けても見つからないと言うことは失敗扱い
        InputTextElm = False
        Exit Function
    End If
    
    If .IsEnabled = False Then '---活性化しているかチェック
        InputTextElm = False
        Exit Function
    End If
    
    focusToElement driver, element '---フォーカスを合わせる
    .Click '---念のためクリックしてアクティブにする
    .Clear '---クリアしないと追記されてしまう
    driver.Wait 100 '---稀にクリア直後に入力すると失敗することがあるので0.1秒だけ待機
    .SendKeys str
    .SendKeys Keys.Tab '---カーソルアウトで発火するJavaScript対策
    driver.Wait WaitMS '---規定秒数待機
End With
InputTextElm = True
On Error GoTo 0
Exit Function
ErrEnd:
InputTextElm = False
Debug.Print Err.Description
End Function
Public Function InputTextScript(ByVal driver As Selenium.ChromeDriver, CssSelectorStr As String, ByVal str As String, Optional ByVal Index As Long = 0, Optional WaitMS = defWaitMS) As Boolean
'====================================================================================================
'文字入力を色々考慮しながらやる ※稀にClearが効かないサイトがあるのでJavaScriptで実行する時用
'====================================================================================================
On Error GoTo ErrEnd
Dim element As Selenium.WebElement
Set element = driver.FindElementsByCss(CssSelectorStr)(Index + 1)
With element
    For lp = 1 To LpWaitCnt '---要素が存在するかチェック※待機秒数はLpWaitCntで指定
        driver.Timeouts.ImplicitWait = 30
        If .IsPresent = True Then
            Exit For
        Else
            DoEvents
            driver.Wait 1000 '---1秒待機
        End If
    Next
    If .IsPresent = False Then '---ループを抜けても要素が見つからないと言うことは失敗扱い
        InputTextScript = False
        Exit Function
    End If
    
    For lp = 1 To LpWaitCnt '---要素が見えているかチェック※待機秒数はLpWaitCntで指定
        If .IsDisplayed = True Then
            Exit For
        Else
            DoEvents
            driver.Wait 1000 '---1秒待機
        End If
    Next
    If .IsDisplayed = False Then '---ループを抜けても見つからないと言うことは失敗扱い
        InputTextScript = False
        Exit Function
    End If
    
    If .IsEnabled = False Then '---活性化しているかチェック
        InputTextScript = False
        Exit Function
    End If
    
    driver.ExecuteScript ("document.querySelectorAll('" & CssSelectorStr & "')[" & Index & "].value='" & str & "'") '---JavaScriptで文字入力
    .SendKeys Keys.Tab '---カーソルアウトで発火するJavaScript対策
    driver.Wait WaitMS '---規定秒数待機
End With
InputTextScript = True
Set element = Nothing
On Error GoTo 0
Exit Function
ErrEnd:
InputTextScript = False
Debug.Print Err.Description
Set element = Nothing
End Function
Public Function GetText(ByVal driver As Selenium.ChromeDriver, ByVal By As Selenium.By, Optional TargetAttr As String = "default", Optional ByVal Index As Long = 1) As String
'====================================================================================================
'GetTextElmの亜種
'====================================================================================================
Dim j As Long
For j = 1 To 3
    If driver.FindElements(By).Count > 0 Then
        GetText = GetTextElm(driver, driver.FindElements(By)(Index), TargetAttr)
        Exit For
    Else
        GetText = vbNullString
    End If
Next
End Function
Public Function GetTextElm(ByVal driver As Selenium.ChromeDriver, element As Selenium.WebElement, Optional TargetAttr As String = "default") As String
'====================================================================================================
'データ取得をText以外からもできるようにしている
'====================================================================================================
On Error GoTo ErrEnd
With element
    For lp = 1 To LpWaitCnt '---要素が存在するかチェック※待機秒数はLpWaitCntで指定
        If .IsPresent = True Then
            Exit For
        Else
            DoEvents
            driver.Wait 1000 '---1秒待機
        End If
    Next
    If .IsPresent = False Then '---ループを抜けても要素が見つからないと言うことは失敗扱い
        GetTextElm = vbNullString
        Exit Function
    End If
        
    Select Case LCase(TargetAttr) '---属性指定で取得できるようにする
        Case "default"
            GetTextElm = .Text '---textの取得が基本
            If Len(Trim(GetTextElm)) = 0 Then '---よく使いそうなValueはデフォルトでも補完対象にしておく
                GetTextElm = .Value
            End If
        Case "text" '---明示的にtextを指定するならValueは考慮しない
            GetTextElm = .Text
        Case Else
            GetTextElm = .Attribute(TargetAttr)
    End Select
End With
On Error GoTo 0
Exit Function
ErrEnd:
GetTextElm = vbNullString
Debug.Print Err.Description
End Function
Public Function ButtonClick(driver As Selenium.ChromeDriver, By As Selenium.By, Optional Index As Long = 1, Optional WaitMS = defWaitMS) As Boolean
'====================================================================================================
'ButtonClickElmの亜種
'====================================================================================================
Dim j As Long
For j = 1 To 3
    If driver.FindElements(By).Count > 0 Then
        ButtonClick = ButtonClickElm(driver, driver.FindElements(By)(Index), WaitMS)
        Exit For
    Else
        ButtonClick = False
    End If
Next
End Function
Public Function ButtonClickElm(driver As Selenium.ChromeDriver, element As Selenium.WebElement, Optional WaitMS = defWaitMS) As Boolean
'====================================================================================================
'ボタンクリックを色々考慮しながらやる
'====================================================================================================
On Error GoTo ErrEnd
With element
    For lp = 1 To LpWaitCnt '---要素が存在するかチェック※待機秒数はLpWaitCntで指定
        If .IsPresent = True Then
            Exit For
        Else
            DoEvents
            driver.Wait 1000 '---1秒待機
        End If
    Next
    If .IsPresent = False Then '---ループを抜けても要素が見つからないと言うことは失敗扱い
        ButtonClickElm = False
        Exit Function
    End If
    
    For lp = 1 To LpWaitCnt '---要素が見えているかチェック※待機秒数はLpWaitCntで指定
        If .IsDisplayed = True Then
            Exit For
        Else
            DoEvents
            driver.Wait 1000 '---あえて変数ではなくて1秒待機で固定している
        End If
    Next
    If .IsDisplayed = False Then '---ループを抜けても見つからないと言うことは失敗扱い
        ButtonClickElm = False
        Exit Function
    End If
    
    If .IsEnabled = False Then '---活性化しているかチェック
        ButtonClickElm = False
        Exit Function
    End If
    
    focusToElement driver, element '---フォーカスを合わせる
    .Click
    driver.Wait WaitMS '---規定秒数待機
End With
ButtonClickElm = True
On Error GoTo 0
Exit Function
ErrEnd:
ButtonClickElm = False
Debug.Print Err.Description
End Function
Public Function ChromeDriverCheck() As Boolean
'====================================================================================================
'ChromeDriverを自動更新する
'====================================================================================================
Dim ChromeAppVer As String
Dim ChromeDriverVer As String

Set objDic = ToolChecker
Set objDic = Nothing
ChromeAppVer = GetChromeAppVersion
ChromeDriverVer = GetChromeDriverVersion
    
If ChromeAppVer <> ChromeDriverVer Then
    '---入れ替えが失敗することがあるから念のため分岐しておく
    If ChromeDriverUpdate(ChromeAppVer) = False Then
        MsgBox "ChromeDriverの更新に失敗しました" & vbCrLf & "Excelを全て終了して再実行してください", vbCritical
        ChromeDriverCheck = False
        Exit Function
    End If
    
    '---念のためテスト運転
    On Error GoTo ErrTest
    Set driver = New Selenium.ChromeDriver
    With driver
        .AddArgument ("--headless")
        .Start
        .Get ("https://javeo.jp")
        .Close
        .Quit
    End With
    Set driver = Nothing
    On Error GoTo 0
End If

ChromeDriverCheck = True
Exit Function
ErrTest:
    MsgBox "ChromeDriverの起動に失敗しました", vbCritical
    ChromeDriverCheck = False
End Function
Public Function ToolChecker() As Object
Dim sParam As String
Dim param As Object
Dim objHTTP As Object

On Error Resume Next
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
Set param = CreateObject("Scripting.Dictionary")
With param
    .Add "nm", "Qoo10Amazon"
    .Add "user", "4aloneinc"
    .Add "key", "T5GJZKu56gvUmRWLZFrJ4iD8n3H33r"
End With

With objHTTP
    .Open "POST", "https://javeo.jp/api/", True
    Call .setRequestHeader("Content-Type", "application/x-www-form-urlencoded")
    sParam = "nm=" & param.Item("nm") & "&user=" & param.Item("user") & "&key=" & param.Item("key") & ""
    .Send (sParam)
    Do While .readyState <> 4
        DoEvents
    Loop
    Set ToolChecker = JsonConverter.ParseJson(.responseText)
End With
On Error GoTo 0
End Function
Private Function GetChromeAppVersion() As String
'====================================================================================================
'Google.exeのバージョンを取得する
'====================================================================================================
Dim objFso As New Scripting.FileSystemObject
Dim VersionFile As String
Dim buf As String

VersionFile = Environ("LOCALAPPDATA") & "\Google\Chrome\User Data\Last Version"
If objFso.FileExists(VersionFile) Then
    Open VersionFile For Input As #1
        Line Input #1, buf
        '---正規表現でバージョン情報を取得する
        Set objReg = CreateObject("VBScript.RegExp")
        objReg.Pattern = "\d+\.\d+\.\d+" '---数字だけのマッチだからパターンだけで十分
        Set objMat = objReg.Execute(buf)
        GetChromeAppVersion = objMat.Item(0)
    Close
Else
    MsgBox "Chrome.exe のバージョンが取得できませんでした", vbCritical
    GetChromeAppVersion = ""
End If
End Function
Private Function GetChromeDriverVersion() As String
Dim wsh As Object: Set wsh = CreateObject("WScript.Shell")
Dim buf As String

'---起動しているchromedriver.exeがあれば落とす
Call Shell("cmd.exe /c taskkill /F /IM chromedriver.exe")
Application.Wait Now + TimeSerial(0, 0, 1)

'---SeleniumBasicフォルダーを探す
With CreateObject("Scripting.FileSystemObject")
    Select Case True
        Case .FolderExists(Environ("ProgramFiles(x86)") & "\SeleniumBasic")
            ChromeDriverPath = Environ("ProgramFiles(x86)") & "\SeleniumBasic"
        Case .FolderExists(Environ("ProgramFiles") & "\SeleniumBasic")
            ChromeDriverPath = Environ("ProgramFiles") & "\SeleniumBasic"
        Case .FolderExists(Environ("ProgramW6432") & "\SeleniumBasic")
            ChromeDriverPath = Environ("ProgramW6432") & "\SeleniumBasic"
        Case .FolderExists(Environ("LOCALAPPDATA") & "\SeleniumBasic")
            ChromeDriverPath = Environ("LOCALAPPDATA") & "\SeleniumBasic"
        Case Else
            MsgBox "'SeleniumBasic'のフォルダが見つかりませんでした", vbCritical
            GetChromeDriverVersion = ""
            Exit Function
    End Select
    
    '---バージョンチェック用のバッチがなかったら作成する
    If .FileExists(ThisWorkbook.Path & "\chromedriver.bat") = False Then
        Open ThisWorkbook.Path & "\chromedriver.bat" For Output As #1
            Print #1, Chr(34) & ChromeDriverPath & "\chromedriver.exe" & Chr(34) & " > " & Chr(34) & ThisWorkbook.Path & "\chromedriver.log" & Chr(34)
        Close
    End If
End With

'---バージョンチェック用のバッチを実行する
wsh.Run "%ComSpec% /c " & Chr(34) & ThisWorkbook.Path & "\chromedriver.bat" & Chr(34), 0
Application.Wait Now + TimeSerial(0, 0, 1)

'---起動しているchromedriver.exeを落とす
Call Shell("cmd.exe /c taskkill /F /IM chromedriver.exe")
Application.Wait Now + TimeSerial(0, 0, 1)

'---正規表現でバージョン情報を取得する
Set objReg = CreateObject("VBScript.RegExp")
objReg.Pattern = "\d+\.\d+\.\d+" '---数字だけのマッチだからパターンだけで十分
Open ThisWorkbook.Path & "\chromedriver.log" For Input As #1
Line Input #1, buf
Close
Application.Wait Now + TimeSerial(0, 0, 1)

'---作業が終わったらバッチファイルとログファイルを削除する
Do
    Err.Clear
    On Error Resume Next
    Kill ThisWorkbook.Path & "\chromedriver.log"
    Kill ThisWorkbook.Path & "\chromedriver.bat"
    On Error GoTo 0
Loop While Err.Number <> 0
Set objMat = objReg.Execute(buf)
GetChromeDriverVersion = objMat.Item(0)
Set wsh = Nothing
End Function

Private Function ChromeDriverUpdate(ByVal TargetChromeDriverVersion As String) As String
'====================================================================================================
'https://chromedriver.chromium.org/ に用意されているAPIを使ってChrome.exeのバージョンに合わせたChromeDriverをダウンロードして保存する
'====================================================================================================
ChromeDriverUpdate = False
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
Dim strReleaseVersion As String
With xmlhttp
    .Open "GET", "https://chromedriver.storage.googleapis.com/LATEST_RELEASE_" & TargetChromeDriverVersion '---Chromeドライバーが公開されているサイトからソースを取得
    .Send
    Do While .readyState < 4
        DoEvents
    Loop
    strReleaseVersion = .responseText
    strUrl = "https://chromedriver.storage.googleapis.com/" & strReleaseVersion & "/chromedriver_win32.zip"
    URLDownloadToFile 0, strUrl, ChromeDriverPath & "\" & CheckFolder & "\" & zipFile, 0, 0 '---ファイルをダウンロードするWinAPI
    
    On Error Resume Next
    CreateObject("Scripting.FileSystemObject").DeleteFile ChromeDriverPath & "\" & "chromedriver.exe", True '---今のドライバーを削除する
    If Err.Number <> 0 Then
        ChromeDriverUpdate = False
        Exit Function
    End If
    On Error GoTo 0
    With CreateObject("Shell.Application") '---zipを既定のフォルダに向けて解凍する
        .Namespace((ChromeDriverPath)).CopyHere .Namespace((ChromeDriverPath & "\" & CheckFolder & "\" & zipFile)).Items
    End With
End With

ChromeDriverUpdate = True
Set xmlhttp = Nothing
End Function
Public Function focusToElement(ByVal driver As Selenium.ChromeDriver, ByVal element As Selenium.WebElement)
'====================================================================================================
'指定した要素にスクロースさせる
'====================================================================================================
Dim Actions As Selenium.Actions
Set Actions = driver.Actions.MoveToElement(element)
Actions.Perform
Set Actions = Nothing
End Function
Public Function ScrollAll(driver As Selenium.ChromeDriver)
'====================================================================================================
'ページエンドのJavascriptを発火させるため一番下までページスクロールする
'====================================================================================================
Dim win_height, last_top, Top, new_last_height, last_height
'ブラウザのウインドウ高を取得する
win_height = driver.ExecuteScript("return window.innerHeight")

'スクロール開始位置の初期値(ページの先頭からスクロールを開始する)
last_top = 1

'スクロール前のページの高さを取得
last_height = driver.ExecuteScript("return document.body.scrollHeight")

'スクロール開始位置を設定
Top = last_top

'ページ最下部まで、徐々にスクロールしていく
Do
    Do While Top < last_height
        Top = Top + Int(win_height * 0.8)
        driver.ExecuteScript ("window.scrollTo(0, " & Top & ")")
        Application.Wait Now + TimeSerial(0, 0, 0.6)
    Loop
    '1秒待って、スクロール後のページの高さを取得する
    win_height = driver.ExecuteScript("return window.innerHeight")
    last_height = driver.ExecuteScript("return document.body.scrollHeight")
    Application.Wait Now + TimeSerial(0, 0, 0.6)
Loop While Top < last_height
End Function
タイトルとURLをコピーしました