このモジュールを入れておけば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 By As New Selenium.By
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.WebDriver, ByVal By As Selenium.By, Optional CheckMode As Long = 0, Optional ByVal Index As Long = 1, Optional TotalWaitSec As Long = 30) As Boolean
RemainingSec = TotalWaitSec
Do While RemainingSec > 0 '---要素が存在するかチェック
If driver.FindElements(By).Count >= Index Then
ViewCheck = ViewCheckElm(driver, driver.FindElements(By)(Index), CheckMode, RemainingSec)
Exit Function
End If
driver.Wait 1000
RemainingSec = RemainingSec - 1
Loop
ViewCheck = False
End Function
Public Function ViewCheckElm(ByVal driver As Selenium.WebDriver, element As Selenium.WebElement, Optional CheckMode As Long = 0, Optional TotalWaitSec As Long = 30) As Boolean
'==============================
'CheckMode
'0:活性化しているかまで
'1:画面上に表示されているかまで
'2:DOMに存在しているかまで
'==============================
On Error GoTo ErrEnd
RemainingSec = TotalWaitSec
With element
Do While RemainingSec > 0 '---要素が存在するかチェック
If .IsPresent = True Then
Exit Do
Else
DoEvents
driver.Wait 1000 '---1秒待機
End If
RemainingSec = RemainingSec - 1
Loop
If .IsPresent = False Then '---ループを抜けても要素が見つからないと言うことは失敗扱い
ViewCheckElm = False
Exit Function
End If
If CheckMode <= 1 Then
Do While RemainingSec > 0 '---要素が見えているかチェック
If .IsDisplayed = True Then
Exit Do
Else
DoEvents
driver.Wait 1000 '---1秒待機
End If
RemainingSec = RemainingSec - 1
Loop
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.WebDriver, ByVal By As Selenium.By, ByVal str As String, Optional AppendMode As Boolean = False, Optional ByVal Index As Long = 1, Optional WaitMS = defWaitMS, Optional TotalWaitSec As Long = 30, Optional ClearWaitMS As Long = 500) As Boolean
'====================================================================================================
'InputTextElmの亜種
'====================================================================================================
If driver.FindElements(By).Count > 0 Then
InputText = InputTextElm(driver, driver.FindElements(By)(Index), str, AppendMode, WaitMS, TotalWaitSec)
Else
InputText = False
End If
End Function
Public Function InputTextElm(ByVal driver As Selenium.WebDriver, element As Selenium.WebElement, ByVal str As String, Optional AppendMode As Boolean = False, Optional WaitMS = defWaitMS, Optional TotalWaitSec As Long = 30, Optional ClearWaitMS As Long = 500) As Boolean
'====================================================================================================
'文字入力を色々考慮しながらやる
'====================================================================================================
On Error GoTo ErrEnd
RemainingSec = TotalWaitSec
With element
Do While RemainingSec > 0 '---要素が存在するかチェック
driver.Timeouts.ImplicitWait = 30
If .IsPresent = True Then
Exit Do
Else
DoEvents
driver.Wait 1000 '---1秒待機
End If
RemainingSec = RemainingSec - 1
Loop
If .IsPresent = False Then '---ループを抜けても要素が見つからないと言うことは失敗扱い
InputTextElm = False
Exit Function
End If
Do While RemainingSec > 0 '---要素が見えているかチェック
If .IsDisplayed = True Then
Exit Do
Else
DoEvents
driver.Wait 1000 '---1秒待機
End If
RemainingSec = RemainingSec - 1
Loop
If .IsDisplayed = False Then '---ループを抜けても見つからないと言うことは失敗扱い
InputTextElm = False
Exit Function
End If
If .IsEnabled = False Then '---活性化しているかチェック
InputTextElm = False
Exit Function
End If
focusToElement driver, element
.Click '---念のためクリックしてアクティブにする
If AppendMode = False Then '---追記モード判定
.Clear '---クリアしないと追記されてしまう
End If
driver.Wait ClearWaitMS '---稀にクリア直後に入力すると失敗することがあるので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.WebDriver, cssselectors As String, ByVal str As String, Optional ByVal Index As Long = 0, Optional WaitMS = defWaitMS, Optional TotalWaitSec As Long = 30) As Boolean
'====================================================================================================
'文字入力を色々考慮しながらやる ※Clearが効かないサイトがあるのでJavaScriptで実行する時用
'====================================================================================================
On Error GoTo ErrEnd
Dim element As Selenium.WebElement
Set element = driver.FindElementsByCss(cssselectors)(Index + 1)
With element
driver.Timeouts.ImplicitWait = 30
RemainingSec = TotalWaitSec
Do While RemainingSec > 0 '---要素が存在するかチェック
If .IsPresent = True Then
Exit Do
Else
DoEvents
driver.Wait 1000 '---1秒待機
End If
RemainingSec = RemainingSec - 1
Loop
If .IsPresent = False Then '---ループを抜けても要素が見つからないと言うことは失敗扱い
InputTextScript = False
Exit Function
End If
Do While RemainingSec > 0 '---要素が見えているかチェック
If .IsDisplayed = True Then
Exit Do
Else
DoEvents
driver.Wait 1000 '---1秒待機
End If
RemainingSec = RemainingSec - 1
Loop
If .IsDisplayed = False Then '---ループを抜けても見つからないと言うことは失敗扱い
InputTextScript = False
Exit Function
End If
If .IsEnabled = False Then '---活性化しているかチェック
InputTextScript = False
Exit Function
End If
driver.ExecuteScript ("document.querySelectorAll('" & cssselectors & "')[" & 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.WebDriver, ByVal By As Selenium.By, Optional TargetAttr As String = "default", Optional ByVal Index As Long = 1, Optional TotalWaitSec As Long = 30) As String
'====================================================================================================
'GetTextElmの亜種
'====================================================================================================
If driver.FindElements(By).Count > 0 Then
GetText = GetTextElm(driver, driver.FindElements(By)(Index), TargetAttr, TotalWaitSec)
Else
GetText = False
End If
End Function
Public Function GetTextElm(ByVal driver As Selenium.WebDriver, element As Selenium.WebElement, Optional TargetAttr As String = "default", Optional TotalWaitSec As Long = 30) As String
'====================================================================================================
'データ取得をText以外からもできるようにしている
'====================================================================================================
On Error GoTo ErrEnd
With element
RemainingSec = TotalWaitSec
Do While RemainingSec > 0 '---要素が存在するかチェック※待機秒数はLpWaitCntで指定
If .IsPresent = True Then
Exit Do
Else
DoEvents
driver.Wait 1000 '---1秒待機
End If
RemainingSec = RemainingSec - 1
Loop
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
GetTextElm = Trim(GetTextElm)
Exit Function
ErrEnd:
GetTextElm = vbNullString
Debug.Print Err.Description
End Function
Public Function ButtonClick(driver As Selenium.WebDriver, By As Selenium.By, Optional Index As Long = 1, Optional WaitMS = defWaitMS, Optional TotalWaitSec As Long = 30) As Boolean
'====================================================================================================
'ButtonClickElmの亜種
'====================================================================================================
If driver.FindElements(By).Count > 0 Then
ButtonClick = ButtonClickElm(driver, driver.FindElements(By)(Index), WaitMS, TotalWaitSec)
Else
ButtonClick = False
End If
End Function
Public Function ButtonClickElm(driver As Selenium.WebDriver, element As Selenium.WebElement, Optional WaitMS = defWaitMS, Optional TotalWaitSec As Long = 30) As Boolean
'====================================================================================================
'ボタンクリックを色々考慮しながらやる
'====================================================================================================
On Error GoTo ErrEnd
With element
RemainingSec = TotalWaitSec
Do While RemainingSec > 0 '---要素が存在するかチェック※待機秒数はLpWaitCntで指定
If .IsPresent = True Then
Exit Do
Else
DoEvents
driver.Wait 1000 '---1秒待機
End If
RemainingSec = RemainingSec - 1
Loop
If .IsPresent = False Then '---ループを抜けても要素が見つからないと言うことは失敗扱い
ButtonClickElm = False
Exit Function
End If
Do While RemainingSec > 0 '---要素が見えているかチェック※待機秒数はLpWaitCntで指定
If .IsDisplayed = True Then
Exit Do
Else
DoEvents
driver.Wait 1000 '---あえて変数ではなくて1秒待機で固定している
End If
RemainingSec = RemainingSec - 1
Loop
If .IsDisplayed = False Then '---ループを抜けても見つからないと言うことは失敗扱い
ButtonClickElm = False
Exit Function
End If
If .IsEnabled = False Then '---活性化しているかチェック
ButtonClickElm = False
Exit Function
End If
.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