１ はじめに
本家のSeleniumではWebDriver BiDi の開発が現在進行中で、次期Selenium5から正式リリースとのことですが、Chromeではすでに対応済でSelenium4でも利用可能となっています。
2025年12月7日現在のSeleniumVBAでは未実装となっていますが、WebDriver BiDiはWebSocket通信により双方向通信が可能となり、私が待ち望んでいたイベント検知ができますので、以下のサイトを参考にチャレンジしてみました。
参考記事ではVBAを使ってWebSocket通信によりCDP接続を行っていますが、これをWebDriver BiDi接続に切り替えて実験したところ期待どおりのものとなり、WebDriver BiDiの実装は技術的に可能です。
また、同様な記事をnoteにも掲載していますが、SeleniumVBAへの実装手順の説明はこの記事のみとなります。
２ SeleniumVBAへの実装手順
(1) VBAからWebSocket通信を利用するために必要なWinHttpのAPI関数群やユーザビリティ向上のためのラッパーが格納されたクラスモジュール（先頭にBiDiがついた3つのクラスモジュール）がサンプルファイルに格納されているので、運用したいSeleniumVBAファイルにインポートします。
(2) クラスモジュール「WebDriver」内に以下のコードを追加して、必要な情報を変数に格納して設定や取得ができるようにします。
VBA
'宣言セクション内に追加
Private webSocketUrl_ As String
'「Public Sub OpenBrowser」内のsessionId_ = resp("sessionId")の次に追加
webSocketUrl_ = resp("capabilities")("webSocketUrl")
'以下のコードを追加
Public Property Get GetWebSocketUrl() As String
GetWebSocketUrl = webSocketUrl_
End Property
Public Property Get GetLocalPort() As String
GetLocalPort = Right(driverUrl_, 4)
End Property
(3) クラスモジュール「WebJsonConverter」内に以下の部分をコメントアウトして、RealmIdの文字列が自動的に数値に変換されることを防止します。
VBA
Case VBA.vbString
' String (or large number encoded as string)
' If (Not JsonOptions.UseDoubleForLargeNumbers) And json_StringIsLargeNumber(jsonValue) Then
' ConvertToJson = jsonValue
' Else
ConvertToJson = """" & json_Encode(jsonValue) & """"
' End If
【以下標準モジュール】
(4) 標準モジュールのメインルーチンで、StartEdge(StartChrome）のあとに以下の記述を入れます。この記述によりWebDriver Bidiが有効に動作します。
VBA
caps.SetCapability "webSocketUrl", True
(5) 標準モジュールのメインルーチンで以下のコードを実行するとWebSocket通信が利用できるようになり、あわせてWebDriver BiDiのラッパーも利用できるようになります。
VBA
' Initialize wrapper and socket
Dim socket As BiDiSocketCommunicator: Set socket = New BiDiSocketCommunicator
socket.AttemptAutoConnect driver
Dim wrapper As BiDiCommandWrapper: Set wrapper = New BiDiCommandWrapper
' Set driver/socket instance to wrapper
Set wrapper.SetDriver = driver: Set wrapper.SetSocket = socket
３ VBAコード
AIにBiDiのscript.callFunctionメソッドでJavaScriptによるコマンドを生成させると、実用性のあるコードが生成されました。なお、意図した動作はしていますが今後検証して改善していきます。サンプルファイルはこちらにあります。
（１）セレクトボックス選択後の非同期のイベント完了まで待機
WebDriver BiDiに一番期待していたのがこの処理です。業務システムにおいてセレクトボックスを選択すると料金が自動計算される非同期のイベントが発生するため対応に苦慮していました。未検証ですがAjaxを利用したサンプルサイトを題材にAIに生成させましたら意図したとおりに動作しています。
VBA
Option Explicit
' Message box that is always displayed in the foreground
Public Declare PtrSafe Function MESSAGEbox Lib "user32.dll" Alias "MessageBoxA" _
(ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long) As Long
Public Const MB_OK = &H0 ' OK button flag
Public Const MB_ForeFront = &H40000 ' Topmost flag
' [Select Box (Wait for completion if an event occurs)]
Public Sub Main01()
Dim driver As WebDriver: Set driver = New WebDriver
With driver
' Start
.StartChrome
' Browser startup settings (for both Chrome and Edge)
Dim caps As SeleniumVBA.WebCapabilities: Set caps = .CreateCapabilities
' /Open maximized
caps.AddArguments "--start-maximized"
' /Do not show intrusive guidance messages from Chrome
caps.AddArguments "--propagate-iph-for-testing"
' Required to enable Chrome extensions
caps.AddArguments "--remote-debugging-pipe"
caps.AddArguments "--enable-unsafe-extension-debugging"
' ==========================================
' Enable BiDi (True is mandatory for this program)
caps.SetCapability "webSocketUrl", True
' ==========================================
' Open
.OpenBrowser caps
' Initialize wrapper and socket
Dim socket As BiDiSocketCommunicator: Set socket = New BiDiSocketCommunicator
socket.AttemptAutoConnect driver
Dim wrapper As BiDiCommandWrapper: Set wrapper = New BiDiCommandWrapper
' Set driver/socket instance to wrapper
Set wrapper.SetDriver = driver: Set wrapper.SetSocket = socket
' --- 1. Execute BiDi Commands ---
' Enable Chrome extension
Dim extensionPath As String
extensionPath = Environ("LOCALAPPDATA") & "\Google\Chrome\User Data\Selenium\Extensions\aapbdbdomjkkjkaonfhkkikfgjllcleb\2.0.16_0"
wrapper.ExecuteWebExtensionInstall (extensionPath)
' Subscribe to event detection
Dim eventsToSubscribe() As String
eventsToSubscribe = Split("network.responseCompleted", ",")
wrapper.ExecuteSessionSubscribe eventsToSubscribe
' Navigate to page
Dim Url As String: Url = "http://keylopment.com/faq/2357"
wrapper.ExecuteBrowsingContextNavigate Url
' --- 2. Search for XPath element and execute click ---
' XPath of the option element displaying March 2026
Dim strClickXpath As String: strClickXpath = "//select[@name='calselect']"
' Search for XPath element and execute click (Argument is the Value of the Option tag)
wrapper.ExecuteSelectValueAndWaitByXPath strClickXpath, "20260301"
' --- 3. Verification and Termination ---
Dim str As String
' Check if the calendar switched as expected
str = .FindElement(By.xPath, "//h3[@class='title-level03']").GetText
Dim msgText As String, msgCaption As String
' Note: Keeping "2026年03月" in Japanese as it compares against site content
If str = "2026年03月" Then
msgText = "Successfully waited until the calendar switched."
msgCaption = "Verification Complete"
MESSAGEbox 0, msgText, msgCaption, MB_OK Or MB_ForeFront
Stop
Else
msgText = "The calendar has not switched. Retrieved value: " & str
msgCaption = "Verification Failed"
MESSAGEbox 0, msgText, msgCaption, MB_OK Or MB_ForeFront
Stop
End If
' End
.CloseBrowser
.Shutdown
End With
End Sub
（２）動的ページの読込完了待機
noteの小説カテゴリを題材にしています。留意点を次章に記載しています。
VBA
Option Explicit
' [Wait until page load is complete]
Public Sub Main02()
Dim driver As WebDriver: Set driver = New WebDriver
With driver
' Start
.StartChrome
' Browser startup settings (for both Chrome and Edge)
Dim caps As SeleniumVBA.WebCapabilities: Set caps = .CreateCapabilities
' /Open maximized
caps.AddArguments "--start-maximized"
' ==========================================
' Enable BiDi (True is mandatory for this program)
caps.SetCapability "webSocketUrl", True
' ==========================================
' Open
.OpenBrowser caps
' Initialize wrapper and socket
Dim socket As BiDiSocketCommunicator: Set socket = New BiDiSocketCommunicator
socket.AttemptAutoConnect driver
Dim wrapper As BiDiCommandWrapper: Set wrapper = New BiDiCommandWrapper
' Set driver/socket instance to wrapper
Set wrapper.SetDriver = driver: Set wrapper.SetSocket = socket
' --- 1. Execute BiDi Commands ---
' Subscribe to event detection
Dim eventsToSubscribe() As String
eventsToSubscribe = Split("network.responseCompleted", ",")
wrapper.ExecuteSessionSubscribe eventsToSubscribe
' Navigate to page
Dim Url As String: Url = "https://note.com/topic/novel"
Dim statusCode As Long
statusCode = wrapper.ExecuteNavigateAndGetStatus(Url, 1500)
' --- 2. Wait process verification ---
Dim elms_title1 As WebElements ' List of article elements
Dim elms_title2 As WebElements ' List of article elements (after waiting)
' [1st time] Search article count with FindElements
Set elms_title1 = .FindElements(By.CssSelector, ".a-link.m-largeNoteWrapper__link.fn")
' Wait 4 seconds
.Wait 4000
' [2nd time] Search article count with FindElements
Set elms_title2 = .FindElements(By.CssSelector, ".a-link.m-largeNoteWrapper__link.fn")
' [Verification of page load completion]
Dim msgText As String, msgCaption As String
If elms_title1.Count <> elms_title2.Count Then
msgText = "Waited, but" & Chr(10) & "statusCode: " & statusCode & Chr(10) & " - Initial article count: " & elms_title1.Count & Chr(10) & " - Article count after 4 sec: " & elms_title2.Count & Chr(10) & " therefore the wait time is insufficient."
msgCaption = "Wait Insufficient statusCode: " & statusCode
MESSAGEbox 0, msgText, msgCaption, MB_OK Or MB_ForeFront
Stop ' Refer to Immediate Window
Else
msgText = "Waited, but" & Chr(10) & "statusCode: " & statusCode & Chr(10) & " - Initial article count: " & elms_title1.Count & Chr(10) & " - Article count after 4 sec: " & elms_title2.Count & Chr(10) & " therefore it waited as expected."
msgCaption = "Wait Complete"
MESSAGEbox 0, msgText, msgCaption, MB_OK Or MB_ForeFront
Stop ' Refer to Immediate Window
End If
' End
.CloseBrowser
.Shutdown
End With
End Sub
（３）簡易ラッパー
クラスモジュールBiDiCommandWrapper内に記述しています。
コード量は多いですがAI(Gemini3.0)に助けてもらっています。以下の機能が含まれています。
・WebDriver BiDiのみでの対応となったChrome拡張機能の読込
・ログイン状態でもステータスコードを取得する
・テキストボックスに文字入力する
・ログイン入力完了まで待機する
・画像と広告を非表示にする
・待機処理も考慮したShadowDOM内検索をする
Option Explicit
' ========================================================================================
' Class Name: BiDiCommandWrapper
' Summary: High-Level Wrapper for Selenium WebDriver BiDi (Enhanced for SPA & CDP).
' Features "Anti-Freeze" logic for Alerts/Prompts and "Physical Input" simulation.
' Dependencies: BiDiSocketCommunicator, WebJsonConverter, Microsoft Scripting Runtime
' ========================================================================================
Private Const DEBUG_MODE As Boolean = True
Private driver_ As WebDriver
Private socket_ As BiDiSocketCommunicator
' Internal State Variables
Private p_nextRequestId As Long
Private p_mainContextId As String
Private p_mainRealmId As String
Private p_cdpSessionId As String
Private Const REALM_DEFAULT_TARGET As String = "context"
' ========================================================================================
' Initialization & Properties
' ========================================================================================
Private Sub Class_Initialize()
p_nextRequestId = 1
End Sub
Public Property Set SetDriver(driver As WebDriver)
Set driver_ = driver
End Property
Public Property Set SetSocket(socket As BiDiSocketCommunicator)
Set socket_ = socket
End Property
' ========================================================================================
' [Strategy A] Anti-Freeze Alert/Prompt Handling (JS Delegation)
' ========================================================================================
' Method: ExecuteClickAndHandleAlertByXPath
' Summary: Clicks an element that triggers a popup (Alert/Confirm) without freezing VBA.
' Logic: Uses JavaScript `setTimeout` to decouple the click event from the command response.
' Use this when you expect an Alert to appear immediately after clicking.
Public Function ExecuteClickAndHandleAlertByXPath(ByVal xPath As String, Optional ByVal accept As Boolean = True) As String
Dim sharedId As String: sharedId = GetSharedIdFromXPath(xPath)
If sharedId = "" Then ExecuteClickAndHandleAlertByXPath = "{""error"":""element not found""}": Exit Function
Dim realmId As String: realmId = GetScriptRealmId()
Dim params As New Dictionary, target As New Dictionary, args As New Collection, arg1 As New Dictionary
' JS Strategy: Schedule click for the next tick (0ms) to return control to VBA immediately.
Dim js As String
js = "function(e) { " & _
" setTimeout(function(){ e.click(); }, 0); " & _
" return 'Click scheduled'; " & _
"}"
arg1.Add "sharedId", sharedId
args.Add arg1
target.Add "realm", realmId
params.Add "functionDeclaration", js
params.Add "arguments", args
params.Add "target", target
params.Add "awaitPromise", False ' Return immediately
' 1. Execute Click (Non-blocking)
ExecuteClickAndHandleAlertByXPath = ExecuteBiDiCommand("script.callFunction", params)
' 2. Wait briefly for the Alert to appear (approx 500ms)
Dim t As Single: t = Timer
Do While Timer - t < 0.5: DoEvents: Loop
' 3. Handle the Alert via BiDi
ExecuteHandleUserPrompt accept
End Function
' Method: ExecuteHandleUserPrompt
' Summary: Closes an open Alert/Confirm/Prompt via BiDi.
Public Function ExecuteHandleUserPrompt(ByVal accept As Boolean, Optional ByVal userText As String = "") As String
Dim contextId As String: contextId = UpdateMainContextId()
Dim params As New Dictionary
params.Add "context", contextId
params.Add "accept", accept
If Len(userText) > 0 Then
params.Add "userText", userText
End If
' Use error handling in case no prompt exists
On Error Resume Next
ExecuteHandleUserPrompt = ExecuteBiDiCommand("browsingContext.handleUserPrompt", params)
If Err.Number <> 0 Then
Debug.Print "BiDi Info: No prompt found to handle."
Err.Clear
Else
Debug.Print "BiDi: User prompt handled (Accept=" & accept & ")"
End If
On Error GoTo 0
End Function
' ========================================================================================
' [Strategy B] Physical Input Simulation (input.performActions)
' ========================================================================================
' Method: ExecuteInputClick
' Summary: Simulates a real physical mouse click (Move -> Down -> Up).
' Use Case: 1. Sites that ignore JS clicks (security checks).
' 2. Elements requiring `isTrusted = true` events.
' Warning: Avoid using this if the button triggers an Alert, as it may freeze VBA waiting for response.
Public Function ExecuteInputClick(ByVal xPath As String) As String
Dim contextId As String: contextId = UpdateMainContextId()
Dim sharedId As String: sharedId = GetSharedIdFromXPath(xPath)
If sharedId = "" Then ExecuteInputClick = "{""error"":""element not found""}": Exit Function
Dim params As New Dictionary
params.Add "context", contextId
Dim actions As New Collection
Dim actionSeq As New Dictionary
' Define Input Source (Mouse)
actionSeq.Add "type", "pointer"
actionSeq.Add "id", "mouse_input_vba"
Dim steps As New Collection
Dim stepMove As New Dictionary, stepDown As New Dictionary, stepUp As New Dictionary
' Step 1: Move mouse to element center
stepMove.Add "type", "pointerMove"
stepMove.Add "origin", BuildOriginObject(sharedId)
stepMove.Add "x", 0
stepMove.Add "y", 0
' Step 2: Mouse Down (Left Button)
stepDown.Add "type", "pointerDown"
stepDown.Add "button", 0
' Step 3: Mouse Up (Left Button)
stepUp.Add "type", "pointerUp"
stepUp.Add "button", 0
steps.Add stepMove
steps.Add stepDown
steps.Add stepUp
actionSeq.Add "actions", steps
actions.Add actionSeq
params.Add "actions", actions
ExecuteInputClick = ExecuteBiDiCommand("input.performActions", params)
End Function
' Helper for Input Actions
Private Function BuildOriginObject(ByVal sharedId As String) As Dictionary
Dim origin As New Dictionary
Dim element As New Dictionary
element.Add "sharedId", sharedId
origin.Add "type", "element"
origin.Add "element", element
Set BuildOriginObject = origin
End Function
' ========================================================================================
' Navigation & Waiting Logic (Hybrid: Events + Polling)
' ========================================================================================
' Method: ExecuteBiDiWaitUntilUrlContains
' Summary: Waits for the URL to change (Supports SPA, Hash changes, and Standard loads).
Public Function ExecuteBiDiWaitUntilUrlContains(ByVal partialUrl As String, Optional ByVal timeoutSec As Long = 300) As Boolean
Dim startTime As Single: startTime = Timer
Dim lastCheckTime As Single: lastCheckTime = Timer
Dim receivedMsg As String
Dim json As Object
' Subscribe to standard navigation events
Dim events(2) As String
events(0) = "network.responseCompleted" ' For standard HTTP loads
events(1) = "browsingContext.load" ' For load completion
events(2) = "browsingContext.fragmentNavigated" ' For SPA hash changes
Me.ExecuteSessionSubscribe events
Debug.Print "BiDi: Waiting for URL containing '" & partialUrl & "'..."
Do
' 1. Check Events (Push)
receivedMsg = socket_.GetMessage()
If Len(receivedMsg) > 0 Then
Set json = WebJsonConverter.ParseJson(receivedMsg)
If json.Exists("method") Then
Select Case json("method")
Case "browsingContext.load", "browsingContext.fragmentNavigated"
If json("params")("url") Like "*" & partialUrl & "*" Then
Debug.Print "BiDi: [Nav Event] Target URL Detected!"
ExecuteBiDiWaitUntilUrlContains = True
Exit Function
End If
Case "network.responseCompleted"
If json("params").Exists("response") Then
Dim res As Object: Set res = json("params")("response")
If InStr(res("url"), partialUrl) > 0 Then
If InStr(LCase(res("mimeType")), "text/html") > 0 Then
Debug.Print "BiDi: [Response HTML] Target URL Detected!"
ExecuteBiDiWaitUntilUrlContains = True
Exit Function
End If
End If
End If
End Select
End If
End If
' 2. Periodic Polling (Pull) - Safety net for silent SPA updates
If Timer - lastCheckTime > 0.5 Then
Dim currentUrl As String
currentUrl = ExecuteGetLocationHref()
If InStr(currentUrl, partialUrl) > 0 Then
Debug.Print "BiDi: [Script Check] Target URL Detected!"
ExecuteBiDiWaitUntilUrlContains = True
Exit Function
End If
lastCheckTime = Timer
End If
' Timeout Check
If Timer - startTime > timeoutSec Then
Debug.Print "BiDi: Wait Timed out."
ExecuteBiDiWaitUntilUrlContains = False
Exit Function
End If
DoEvents
Loop
End Function
' Method: ExecuteNavigateAndGetStatus
' Summary: Navigates to a URL and captures the HTTP Status code (200, 404, etc.)
Public Function ExecuteNavigateAndGetStatus(ByVal targetUrl As String, _
Optional ByVal afterLoadIdleMs As Long = 500) As Long
Me.Subscribe Array("network.responseCompleted", "browsingContext")
Dim contextId As String: contextId = UpdateMainContextId(forceUpdate:=True)
Dim params As New Dictionary
params.Add "context", contextId
params.Add "url", targetUrl
params.Add "wait", "none" ' We handle the wait manually to catch events
ExecuteBiDiCommand "browsingContext.navigate", params
Dim startTime As Single: startTime = Timer
Dim receivedMsg As String, json As Object
Dim foundStatus As Long: foundStatus = 0
Dim isLoadComplete As Boolean: isLoadComplete = False
Const MAX_TIMEOUT_MS As Long = 30000
Do While Timer - startTime < (MAX_TIMEOUT_MS / 1000)
receivedMsg = socket_.GetMessage()
If Len(receivedMsg) > 0 Then
Set json = WebJsonConverter.ParseJson(receivedMsg)
If json.Exists("method") Then
' Capture HTTP Status from Network Response
If json("method") = "network.responseCompleted" Then
If json("params").Exists("response") Then
Dim res As Object: Set res = json("params")("response")
Dim mime As String: mime = LCase(res("mimeType"))
' Filter for main document (HTML)
If (InStr(mime, "text/html") > 0 Or InStr(mime, "application/xhtml+xml") > 0) Then
If InStr(res("url"), targetUrl) > 0 Or InStr(targetUrl, res("url")) > 0 Then
foundStatus = res("status")
End If
End If
End If
End If
' Check Load Complete Event
If json("method") = "browsingContext.load" Then isLoadComplete = True
End If
End If
If foundStatus > 0 And isLoadComplete Then Exit Do
DoEvents
Loop
If isLoadComplete Then
ExecuteScriptCallWaitForPageIdle afterLoadIdleMs
Else
Debug.Print "BiDi Warning: Page load timed out or status not found."
End If
ExecuteNavigateAndGetStatus = foundStatus
End Function
' ========================================================================================
' Core Command Helper
' ========================================================================================
Private Function ExecuteBiDiCommand(ByVal method As String, ByVal params As Dictionary) As String
If driver_ Is Nothing Or socket_ Is Nothing Then Err.Raise 91, , "Driver or Socket object is not set."
Dim dic As New Dictionary
dic.Add "id", p_nextRequestId
dic.Add "method", method
dic.Add "params", params
p_nextRequestId = p_nextRequestId + 1
Dim sendMsg As String
sendMsg = WebJsonConverter.ConvertToJson(dic)
If DEBUG_MODE Then DebugPrintLong "Request", sendMsg
Dim strRes As String
strRes = socket_.SendAndReceive(sendMsg)
If DEBUG_MODE Then DebugPrintLong "Response", strRes
' Global Error Check
If InStr(strRes, """error""") > 0 Or InStr(strRes, """exception""") > 0 Then
CheckAndRaiseError strRes, method
End If
ExecuteBiDiCommand = strRes
End Function
Private Sub CheckAndRaiseError(ByVal jsonString As String, ByVal methodName As String)
Dim json As Object
On Error Resume Next
Set json = WebJsonConverter.ParseJson(jsonString)
On Error GoTo 0
If json Is Nothing Then Exit Sub
Dim errType As String, errMsg As String
' Protocol Level Error
If json.Exists("error") Then
errType = json("error")
If json.Exists("message") Then errMsg = json("message")
Err.Raise vbObjectError + 513, "BiDi:" & methodName, "Browser Error [" & errType & "]: " & errMsg
End If
' JS Execution Exception
If json.Exists("result") Then
If json("result").Exists("exceptionDetails") Then
Dim details As Object
Set details = json("result")("exceptionDetails")
If details.Exists("text") Then errMsg = details("text")
If details.Exists("exception") Then
If details("exception").Exists("description") Then
errMsg = errMsg & " - " & details("exception")("description")
End If
End If
Err.Raise vbObjectError + 514, "BiDi:JS_Exception", "JavaScript Error in " & methodName & ": " & errMsg
End If
End If
End Sub
Private Sub DebugPrintLong(ByVal header As String, ByVal longText As String)
Const CHUNK_SIZE As Integer = 250
Dim i As Long
For i = 1 To Len(longText) Step CHUNK_SIZE
Debug.Print Mid(longText, i, CHUNK_SIZE);
Next i
Debug.Print ""
End Sub
' ========================================================================================
' State Management (Context / Realm / CDP Session)
' ========================================================================================
Public Sub ClearState()
p_mainRealmId = ""
p_cdpSessionId = ""
End Sub
Private Function UpdateMainContextId(Optional ByVal forceUpdate As Boolean = False) As String
If Not forceUpdate And p_mainContextId <> "" Then
UpdateMainContextId = p_mainContextId
Exit Function
End If
Dim params As New Dictionary
Dim strRes As String
strRes = ExecuteBiDiCommand("browsingContext.getTree", params)
On Error Resume Next
Dim resJson As Object
Set resJson = WebJsonConverter.ParseJson(strRes)
' Assumes the first context is the main window/tab
p_mainContextId = resJson("result")("contexts")(1)("context")
On Error GoTo 0
UpdateMainContextId = p_mainContextId
End Function
Public Function GetScriptRealmId(Optional ByVal forceUpdate As Boolean = False) As String
If p_mainContextId = "" Then UpdateMainContextId
If Not forceUpdate And p_mainRealmId <> "" Then
GetScriptRealmId = p_mainRealmId
Exit Function
End If
Dim params As New Dictionary
params.Add REALM_DEFAULT_TARGET, p_mainContextId
Dim strRes As String
strRes = ExecuteBiDiCommand("script.getRealms", params)
On Error Resume Next
p_mainRealmId = CStr(WebJsonConverter.ParseJson(strRes)("result")("realms")(1)("realm"))
On Error GoTo 0
If p_mainRealmId = "" And Not forceUpdate Then
' Retry with forced update if realm is missing
UpdateMainContextId forceUpdate:=True
GetScriptRealmId = GetScriptRealmId(forceUpdate:=True)
Else
GetScriptRealmId = p_mainRealmId
End If
End Function
' Get CDP Session ID (Required for Chrome/Edge Network commands)
Private Function GetCdpSessionId(Optional ByVal forceUpdate As Boolean = False) As String
If p_mainContextId = "" Then UpdateMainContextId
If Not forceUpdate And p_cdpSessionId <> "" Then
GetCdpSessionId = p_cdpSessionId
Exit Function
End If
Dim params As New Dictionary
params.Add "context", p_mainContextId
Dim strRes As String
strRes = ExecuteBiDiCommand("goog:cdp.getSession", params)
On Error Resume Next
p_cdpSessionId = WebJsonConverter.ParseJson(strRes)("result")("session")
On Error GoTo 0
GetCdpSessionId = p_cdpSessionId
End Function
Private Function ExecuteGetLocationHref() As String
Dim js As String: js = "function(){ return window.location.href; }"
Dim realmId As String: realmId = GetScriptRealmId()
If realmId = "" Then Exit Function
Dim params As New Dictionary, target As New Dictionary
target.Add "realm", realmId
params.Add "functionDeclaration", js
params.Add "arguments", New Collection
params.Add "target", target
params.Add "awaitPromise", False
Dim strRes As String
strRes = ExecuteBiDiCommand("script.callFunction", params)
On Error Resume Next
ExecuteGetLocationHref = WebJsonConverter.ParseJson(strRes)("result")("result")("value")
On Error GoTo 0
End Function
' ========================================================================================
' Standard Commands
' ========================================================================================
Public Function Subscribe(ByVal events As Variant) As String
Dim params As New Dictionary
If IsArray(events) Then
params.Add "events", events
Else
Dim arr(0) As String: arr(0) = events
params.Add "events", arr
End If
Subscribe = ExecuteBiDiCommand("session.subscribe", params)
End Function
Public Function ExecuteSessionSubscribe(ByRef events() As String) As String
ExecuteSessionSubscribe = Subscribe(events)
End Function
Public Function ExecuteBrowsingContextNavigate(ByVal Url As String, Optional ByVal waitMode As String = "complete") As String
ClearState
Dim contextId As String: contextId = UpdateMainContextId(forceUpdate:=True)
Dim params As New Dictionary
params.Add "context", contextId
params.Add "url", Url
params.Add "wait", waitMode
Dim strRes As String
strRes = ExecuteBiDiCommand("browsingContext.navigate", params)
If InStr(strRes, """type"":""success""") > 0 Then
ExecuteBrowsingContextNavigate = ExecuteScriptCallWaitForPageIdle()
Else
ExecuteBrowsingContextNavigate = strRes
End If
End Function
' ========================================================================================
' Standard Element Interaction (JS Injected) - Fast & Reliable for most cases
' ========================================================================================
Public Function ExecuteBrowsingContextLocateNodes(ByVal xPath As String) As String
Dim contextId As String: contextId = UpdateMainContextId()
Dim params As New Dictionary, locator As New Dictionary
locator.Add "type", "xpath"
locator.Add "value", xPath
params.Add "context", contextId
params.Add "locator", locator
ExecuteBrowsingContextLocateNodes = ExecuteBiDiCommand("browsingContext.locateNodes", params)
End Function
Private Function GetSharedIdFromXPath(ByVal xPath As String) As String
Dim strRes As String
strRes = ExecuteBrowsingContextLocateNodes(xPath)
If InStr(strRes, """nodes"":[]") > 0 Then Exit Function
On Error Resume Next
GetSharedIdFromXPath = WebJsonConverter.ParseJson(strRes)("result")("nodes")(1)("sharedId")
On Error GoTo 0
End Function
' Standard Click (Waits for promise, safe for normal buttons)
Public Function ExecuteClickAndWaitByXPath(ByVal xPath As String) As String
Dim sharedId As String: sharedId = GetSharedIdFromXPath(xPath)
If sharedId = "" Then ExecuteClickAndWaitByXPath = "{""error"":""element not found""}": Exit Function
Dim realmId As String: realmId = GetScriptRealmId()
Dim params As New Dictionary, target As New Dictionary, args As New Collection, arg1 As New Dictionary
arg1.Add "sharedId", sharedId
args.Add arg1
target.Add "realm", realmId
params.Add "functionDeclaration", GetJsForClickAndWait()
params.Add "arguments", args
params.Add "target", target
params.Add "awaitPromise", True
ExecuteClickAndWaitByXPath = ExecuteBiDiCommand("script.callFunction", params)
End Function
Public Function ExecuteInputValueAndWaitByXPath(ByVal xPath As String, ByVal valueToSet As String) As String
Dim sharedId As String: sharedId = GetSharedIdFromXPath(xPath)
If sharedId = "" Then ExecuteInputValueAndWaitByXPath = "{""error"":""element not found""}": Exit Function
Dim realmId As String: realmId = GetScriptRealmId()
Dim params As New Dictionary, target As New Dictionary, args As New Collection, arg1 As New Dictionary, arg2 As New Dictionary
arg1.Add "sharedId", sharedId
args.Add arg1
arg2.Add "type", "string"
arg2.Add "value", valueToSet
args.Add arg2
target.Add "realm", realmId
params.Add "functionDeclaration", GetJsForInputAndWait()
params.Add "arguments", args
params.Add "target", target
params.Add "awaitPromise", True
ExecuteInputValueAndWaitByXPath = ExecuteBiDiCommand("script.callFunction", params)
End Function
Public Function ExecuteGetTextByXPath(ByVal xPath As String) As String
Dim sharedId As String: sharedId = GetSharedIdFromXPath(xPath)
If sharedId = "" Then Exit Function
Dim realmId As String: realmId = GetScriptRealmId()
Dim jsFunction As String: jsFunction = "function(element) { return element.innerText || element.textContent || ''; }"
Dim params As New Dictionary, target As New Dictionary, args As New Collection, arg1 As New Dictionary
arg1.Add "sharedId", sharedId
args.Add arg1
target.Add "realm", realmId
params.Add "functionDeclaration", jsFunction
params.Add "arguments", args
params.Add "target", target
params.Add "awaitPromise", False
Dim strRes As String
strRes = ExecuteBiDiCommand("script.callFunction", params)
On Error Resume Next
ExecuteGetTextByXPath = WebJsonConverter.ParseJson(strRes)("result")("result")("value")
On Error GoTo 0
End Function
Public Function ExecuteSelectValueAndWaitByXPath(ByVal xPath As String, ByVal valueToSet As String) As String
Dim sharedId As String: sharedId = GetSharedIdFromXPath(xPath)
If sharedId = "" Then ExecuteSelectValueAndWaitByXPath = "{""error"":""element not found""}": Exit Function
Dim realmId As String: realmId = GetScriptRealmId()
Dim params As New Dictionary, target As New Dictionary, args As New Collection, arg1 As New Dictionary, arg2 As New Dictionary
arg1.Add "sharedId", sharedId
args.Add arg1
arg2.Add "type", "string"
arg2.Add "value", valueToSet
args.Add arg2
target.Add "realm", realmId
params.Add "functionDeclaration", GetJsForSelectAndWait()
params.Add "arguments", args
params.Add "target", target
params.Add "awaitPromise", True
ExecuteSelectValueAndWaitByXPath = ExecuteBiDiCommand("script.callFunction", params)
End Function
' ========================================================================================
' Wait For Idle (Network + DOM Hybrid)
' ========================================================================================
Public Function ExecuteScriptCallWaitForPageIdle(Optional ByVal idleTimeMs As Long = 500) As String
Dim realmId As String: realmId = GetScriptRealmId()
If realmId = "" Then ExecuteScriptCallWaitForPageIdle = "{""error"":""realm not found""}": Exit Function
Dim params As New Dictionary, target As New Dictionary, args As New Collection
target.Add "realm", realmId
params.Add "functionDeclaration", GetJsForWaitForIdle(idleTimeMs)
params.Add "arguments", args
params.Add "target", target
params.Add "awaitPromise", True
ExecuteScriptCallWaitForPageIdle = ExecuteBiDiCommand("script.callFunction", params)
End Function
' ========================================================================================
' Storage & Extensions & CDP
' ========================================================================================
Public Function ExecuteStorageGetCookies(Optional ByVal filter As Dictionary = Nothing) As Collection
Dim contextId As String: contextId = UpdateMainContextId()
Dim params As New Dictionary, partition As New Dictionary
partition.Add "type", "context"
partition.Add "context", contextId
params.Add "partition", partition
If Not filter Is Nothing Then params.Add "filter", filter
Dim strRes As String
strRes = ExecuteBiDiCommand("storage.getCookies", params)
Dim json As Object: Set json = WebJsonConverter.ParseJson(strRes)
Dim resultColl As New Collection
On Error Resume Next
If json.Exists("result") Then
If json("result").Exists("cookies") Then Set resultColl = json("result")("cookies")
End If
On Error GoTo 0
Set ExecuteStorageGetCookies = resultColl
End Function
Public Function ExecuteStorageSetCookie(ByVal cookieData As Dictionary) As String
Dim contextId As String: contextId = UpdateMainContextId()
Dim params As New Dictionary, partition As New Dictionary
partition.Add "type", "context"
partition.Add "context", contextId
params.Add "partition", partition
params.Add "cookie", cookieData
ExecuteStorageSetCookie = ExecuteBiDiCommand("storage.setCookie", params)
End Function
Public Function ExecuteStorageDeleteCookies(Optional ByVal filter As Dictionary = Nothing) As String
Dim contextId As String: contextId = UpdateMainContextId()
Dim params As New Dictionary, partition As New Dictionary
partition.Add "type", "context"
partition.Add "context", contextId
params.Add "partition", partition
If Not filter Is Nothing Then params.Add "filter", filter
ExecuteStorageDeleteCookies = ExecuteBiDiCommand("storage.deleteCookies", params)
End Function
Public Function ExecuteStorageDeleteAllCookies() As String
Dim filter As New Dictionary
ExecuteStorageDeleteAllCookies = ExecuteStorageDeleteCookies(filter)
End Function
Public Function ExecuteWebExtensionInstall(ByVal extensionPath As String) As String
Dim params As New Dictionary, extData As New Dictionary
extData.Add "type", "archivePath"
extData.Add "archivePath", extensionPath
params.Add "extensionData", extData
Dim res As String
res = ExecuteBiDiCommand("webExtension.install", params)
ExecuteWebExtensionInstall = res
End Function
Public Function ExecuteBrowsingContextPrintAndSave(ByVal pdfFileName As String) As String
Dim contextId As String: contextId = UpdateMainContextId()
Dim params As New Dictionary, page As New Dictionary
page.Add "name", "A4"
params.Add "page", page
params.Add "context", contextId
params.Add "orientation", "portrait"
params.Add "background", True
Dim strRes As String
strRes = ExecuteBiDiCommand("browsingContext.print", params)
Dim resJson As Object: Set resJson = WebJsonConverter.ParseJson(strRes)
On Error Resume Next
Dim b64 As String
b64 = resJson("result")("data")
On Error GoTo 0
If b64 <> "" Then driver_.SaveBase64StringToFile b64, pdfFileName
ExecuteBrowsingContextPrintAndSave = strRes
End Function
Public Function ExecuteCDPCommand(ByVal cdpMethod As String, ByVal cdpParams As Dictionary) As String
Dim params As New Dictionary
params.Add "method", cdpMethod
params.Add "params", cdpParams
' Network commands must target a specific CDP Session
Dim sessionId As String: sessionId = GetCdpSessionId()
If sessionId <> "" Then
params.Add "session", sessionId
Else
Debug.Print "BiDi Warning: CDP Session ID missing. Network commands may fail."
End If
ExecuteCDPCommand = ExecuteBiDiCommand("goog:cdp.sendCommand", params)
End Function
Public Function ExecuteBlockURLs(ByVal patterns As Variant) As String
Dim cdpParams As New Dictionary
cdpParams.Add "urls", patterns
' Enable Network domain
ExecuteCDPCommand "Network.enable", New Dictionary
ExecuteBlockURLs = ExecuteCDPCommand("Network.setBlockedURLs", cdpParams)
End Function
Public Function ExecuteClearBlockedURLs() As String
Dim cdpParams As New Dictionary
cdpParams.Add "urls", Array()
ExecuteClearBlockedURLs = ExecuteCDPCommand("Network.setBlockedURLs", cdpParams)
End Function
' ========================================================================================
' Shadow DOM Interaction
' ========================================================================================
Public Function ExecuteShadowClick(ByVal selectorsArray As Variant) As String
Dim realmId As String: realmId = GetScriptRealmId()
Dim params As New Dictionary, target As New Dictionary, args As New Collection
args.Add BuildShadowSelectorArg(selectorsArray)
target.Add "realm", realmId
params.Add "functionDeclaration", GetJsForShadowClick()
params.Add "arguments", args
params.Add "target", target
params.Add "awaitPromise", True
ExecuteShadowClick = ExecuteBiDiCommand("script.callFunction", params)
End Function
Public Function ExecuteShadowInput(ByVal selectorsArray As Variant, ByVal valueToSet As String) As String
Dim realmId As String: realmId = GetScriptRealmId()
Dim params As New Dictionary, target As New Dictionary, args As New Collection
args.Add BuildShadowSelectorArg(selectorsArray)
Dim arg2 As New Dictionary
arg2.Add "type", "string"
arg2.Add "value", valueToSet
args.Add arg2
target.Add "realm", realmId
params.Add "functionDeclaration", GetJsForShadowInput()
params.Add "arguments", args
params.Add "target", target
params.Add "awaitPromise", True
ExecuteShadowInput = ExecuteBiDiCommand("script.callFunction", params)
End Function
Public Function ExecuteShadowGetText(ByVal selectorsArray As Variant) As String
Dim realmId As String: realmId = GetScriptRealmId()
Dim params As New Dictionary, target As New Dictionary, args As New Collection
args.Add BuildShadowSelectorArg(selectorsArray)
target.Add "realm", realmId
params.Add "functionDeclaration", GetJsForShadowGetText()
params.Add "arguments", args
params.Add "target", target
params.Add "awaitPromise", True
Dim strRes As String
strRes = ExecuteBiDiCommand("script.callFunction", params)
On Error Resume Next
ExecuteShadowGetText = WebJsonConverter.ParseJson(strRes)("result")("result")("value")
On Error GoTo 0
End Function
' ========================================================================================
' JavaScript Generator Helper Functions
' ========================================================================================
Private Function GetJsForWaitForIdle(ByVal idleTimeMs As Long) As String
Dim js As String
js = "function() { return new Promise((resolve) => { "
js = js & " let inflight = 0; "
js = js & " let lastActivity = Date.now(); "
js = js & " const timeoutMs = " & idleTimeMs & "; "
js = js & " const origFetch = window.fetch; "
js = js & " const origOpen = XMLHttpRequest.prototype.open; "
js = js & " const origSend = XMLHttpRequest.prototype.send; "
js = js & " function update() { lastActivity = Date.now(); } "
js = js & " window.fetch = function(u, o) { "
js = js & " inflight++; update(); "
js = js & " return origFetch(u, o).finally(() => { inflight--; update(); }); "
js = js & " }; "
js = js & " XMLHttpRequest.prototype.open = function(...a) { return origOpen.apply(this, a); }; "
js = js & " XMLHttpRequest.prototype.send = function(...a) { "
js = js & " inflight++; update(); "
js = js & " this.addEventListener('loadend', () => { inflight--; update(); }); "
js = js & " return origSend.apply(this, a); "
js = js & " }; "
js = js & " const observer = new MutationObserver(() => update()); "
js = js & " observer.observe(document.body, { childList: true, subtree: true, attributes: true }); "
js = js & " const check = setInterval(() => { "
js = js & " const now = Date.now(); "
js = js & " if (inflight === 0 && (now - lastActivity > timeoutMs)) { "
js = js & " clearInterval(check); "
js = js & " observer.disconnect(); "
js = js & " window.fetch = origFetch; "
js = js & " XMLHttpRequest.prototype.open = origOpen; "
js = js & " XMLHttpRequest.prototype.send = origSend; "
js = js & " resolve('idle'); "
js = js & " } "
js = js & " }, 100); "
js = js & "}); }"
GetJsForWaitForIdle = js
End Function
Private Function GetJsForClickAndWait() As String
Dim js As String
js = "function(e) { return new Promise((r) => { "
js = js & " e.scrollIntoView({block:'center',inline:'center'}); "
js = js & " e.focus(); "
js = js & " e.click(); "
js = js & " setTimeout(() => r('done'), 500); "
js = js & "}); }"
GetJsForClickAndWait = js
End Function
Private Function GetJsForInputAndWait() As String
Dim js As String
js = "function(e,v) { return new Promise((r) => { "
js = js & " e.scrollIntoView({block:'center',inline:'center'}); "
js = js & " e.click(); e.focus(); e.value=''; "
js = js & " var s=document.execCommand('insertText',false,v); "
js = js & " if(!s){ "
js = js & " e.value=v; "
js = js & " e.dispatchEvent(new Event('input',{bubbles:true})); "
js = js & " e.dispatchEvent(new Event('change',{bubbles:true})); "
js = js & " } "
js = js & " e.blur(); "
js = js & " setTimeout(() => r('done'), 500); "
js = js & "}); }"
GetJsForInputAndWait = js
End Function
Private Function GetJsForSelectAndWait() As String
Dim js As String
js = "function(s,v) { return new Promise((r) => { "
js = js & " s.scrollIntoView({block:'center',inline:'center'}); "
js = js & " s.focus(); "
js = js & " s.value = v; "
js = js & " s.dispatchEvent(new Event('change', {bubbles:true})); "
js = js & " s.blur(); "
js = js & " setTimeout(() => r('done'), 500); "
js = js & "}); }"
GetJsForSelectAndWait = js
End Function
Private Function GetJsForShadowClick() As String
Dim js As String
js = "function(selectors) { "
js = js & GetJsCommonFindShadow()
js = js & " return new Promise(async (resolve) => { "
js = js & " const el = await findShadow(selectors); "
js = js & " if (!el) { resolve('Error: Element not found'); return; } "
js = js & " el.scrollIntoView({block:'center',inline:'center'}); "
js = js & " el.focus(); "
js = js & " el.click(); "
js = js & " setTimeout(() => resolve('done'), 500); "
js = js & " }); "
js = js & "}"
GetJsForShadowClick = js
End Function
Private Function GetJsForShadowInput() As String
Dim js As String
js = "function(selectors, val) { "
js = js & GetJsCommonFindShadow()
js = js & " return new Promise(async (resolve) => { "
js = js & " const el = await findShadow(selectors); "
js = js & " if (!el) { resolve('Error: Element not found'); return; } "
js = js & " el.scrollIntoView({block:'center',inline:'center'}); "
js = js & " el.focus(); "
js = js & " el.value = ''; "
js = js & " var s = document.execCommand('insertText', false, val); "
js = js & " if(!s){ "
js = js & " el.value = val; "
js = js & " el.dispatchEvent(new Event('input', {bubbles:true, composed:true})); "
js = js & " el.dispatchEvent(new Event('change', {bubbles:true, composed:true})); "
js = js & " } "
js = js & " el.blur(); "
js = js & " setTimeout(() => resolve('done'), 500); "
js = js & " }); "
js = js & "}"
GetJsForShadowInput = js
End Function
Private Function GetJsForShadowGetText() As String
Dim js As String
js = "function(selectors) { "
js = js & GetJsCommonFindShadow()
js = js & " return new Promise(async (resolve) => { "
js = js & " const el = await findShadow(selectors); "
js = js & " if (!el) { resolve(''); return; } "
js = js & " resolve(el.innerText || el.textContent || ''); "
js = js & " }); "
js = js & "}"
GetJsForShadowGetText = js
End Function
' ========================================================================================
' Internal Helpers
' ========================================================================================
Private Function BuildShadowSelectorArg(ByVal selectorsArray As Variant) As Dictionary
Dim arg As New Dictionary
arg.Add "type", "array"
Dim valList As New Collection
Dim i As Long, valItem As Dictionary
For i = LBound(selectorsArray) To UBound(selectorsArray)
Set valItem = New Dictionary
valItem.Add "type", "string"
valItem.Add "value", selectorsArray(i)
valList.Add valItem
Next i
arg.Add "value", valList
Set BuildShadowSelectorArg = arg
End Function
Private Function GetJsCommonFindShadow() As String
Dim js As String
js = " function findShadow(arr) { "
js = js & " return new Promise((res) => { "
js = js & " const end = Date.now() + 5000; "
js = js & " function check() { "
js = js & " let el = document.querySelector(arr[0]); "
js = js & " let fail = false; "
js = js & " if(el) { "
js = js & " for(let i=1; i<arr.length; i++){ "
js = js & " if(el.shadowRoot) { el = el.shadowRoot.querySelector(arr[i]); } "
js = js & " else { fail = true; break; } "
js = js & " if(!el) { fail = true; break; } "
js = js & " } "
js = js & " } else { fail = true; } "
js = js & " if(!fail && el) res(el); "
js = js & " else if(Date.now() < end) setTimeout(check, 100); "
js = js & " else res(null); "
js = js & " } "
js = js & " check(); "
js = js & " }); "
js = js & " } "
GetJsCommonFindShadow = js
End Function
４ 作業した際の所感
〇 動的ページの読込完了待機について
pageLoadStrategyでは対応できないAJAX等の動的ページの読込完了待機の実験をしていますが、AI(Gemini)と会話した結果、BiDiのscript.callFunctionメソッドでJavaScriptによるコマンドを生成して実行されるのがもっとも安定するとの結果になりました。
理由としてVBAは『非同期処理』が苦手であり、それが得意なJavaScript（ブラウザ）に丸投げするためです。VBAはあくまで「司令塔（コントローラー）」に徹し、複雑な実務は現場（ブラウザ内のJS）に行わせています。
すべてのリクエストが完了した時点でページ読込完了と判断して検知していますが、動的ページの場合は、すべてのリクエスト完了後も再びリスエストが発生することがあるため、リクエスト完了後に指定した秒数をアイドリングして待機するようにしました。
具体的には、未完了のリクエスト数が0になっても終了しないで指定ミリ秒分アイドリングしてから終了するようにし、ミリ秒数は任意に設定できるようにしてあります。
設定秒数は長ければ安定しますが、処理スピードとの兼ね合いで実際に動かしながら、決めていく形になるので、第２引数でミリ秒を指定できるようにしてあります。
〇 AIに指示するにあたって
VBAのWebSocketの仕様により、メッセージの受信がないときにWinHttpWebSocketReceiveを行うとハングアップしてしまいますが、AI(Gemini3.0）は既にお見通しでした。AIはかなりの水準まで進化していることが実感できました。
〇 JSON形式からの文字列の取り出し
保守性を考えるとSeleniumVBAのクラスモジュール「WebJsonConverter」(＠Tim Hall ＠GCuser99)を利用が圧倒的に便利でしたので、ツールの利用は必須です。
５ 起動済ブラウザからの操作
以下のコードにより実験したところ、起動済EdgeからでもWebDriver BiDIを有効にでき、イベントが検知できました。
VBA
'=================================================
'リモートデバッグによりログイン状態のブラウザを自動操作する。
'ショートカットにより、すでに立ち上げた状態から始める。
'=================================================
'ショートカットのリンク先は以下に設定
'"C:\Program Files (x86)\Microsoft\Edge\Application\msedge.exe" --remote-debugging-port=9222 --user-data-dir="C:\EdgeDebugProfile"
'=================================================
Dim caps As SeleniumVBA.WebCapabilities
Set driver = SeleniumVBA.New_WebDriver
driver.StartEdge
Set caps = driver.CreateCapabilities(initializeFromSettingsFile:=False)
caps.SetDebuggerAddress "localhost:9222"
'BiDiを有効にする（このプログラムではTrue必須）
caps.SetCapability "webSocketUrl", True
driver.OpenBrowser caps
'（以下つづく）
６ おわりに
VBA経由でのWebDriver BiDiのWebSocket通信に関する記事が見当たらず、kabkabkab様の記事を頼りに右往左往で進めてきたのが実態で、至らない部分が多く改良の余地は大いにあります。
実験用ファイルでは、ラッパーを装備していますが十分ではないため、課題は残っていますが、VBA経由のBiDi利用への展望が開けてきたのは確かだと思います。
最後になりましたが、WebSocket通信の設定にあたり、kabkabkab様の懇切丁寧な解説を交えた記事に大いに助けられました。お礼を申し上げます。