Edge標準モード自動化の実装例
先日書いたVBAからEdge標準モード自動操作を使った、実装例を紹介します。
私が実務でこの「ブラウザ自動操作」を使って暫く経ちましたが、だいぶ動作が安定してきたので、ここらで具体的な実装例を紹介したいと思います。
どんな風にVBAコードを組立てれば上手く動くのか、動作が安定するのか、事故率を抑えられるのか等、何らかのヒントになれば幸いです。
※自分がブラウザ自動化に取り組み始めた頃、具体的な実装例（参考例）があればどんなに助かっただろうか、という苦い経験を思い出しました。ここでは具体的な要素名やID等は載せられないので抽象度合いは上がりますが、それでも実装例を紹介することで、同じ苦労を抱える方の助けになればと思います。
ちなみに、関連記事としてTips集（〇〇したいときはこう書く）も書いています。シチュエーション毎の対処法を知りたい時はこっちを見てください。
ということで、日々の業務にありがちな、以下の処理を行うVBAコードの実装例です。
【実装例その１】
１．業務ページ（勤怠入力システム）のスタートページを立ち上げる
（ログイン画面に阻まれた場合は、ログイン処理へ進む）
２．ユーザー入力検知機能付きのログイン画面でログイン処理をする
（Tabキーを疑似的に送信することで認証突破）
３．ログイン後に、「打刻」ボタンを押す
'WSA関連
Private Type WSAData 'ソケット初期化用構造体
wVersion As Integer
wHighVersion As Integer
szDescription As String * 257 'WSA_DESCRIPTIONLEN + 1
szSystemStatus As String * 129 'WSA_SYS_STATUS_LEN + 1
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Private Declare PtrSafe Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequired As Integer, ByRef lpWSAData As WSAData) As Long
Private Declare PtrSafe Function WSACleanup Lib "ws2_32.dll" () As Long
Private Declare PtrSafe Function WSAGetLastError Lib "ws2_32.dll" () As Long
'------------------------
'アドレス取得
Private Declare PtrSafe Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long
Private Declare PtrSafe Function htons Lib "ws2_32.dll" (ByVal hostshort As Long) As Integer
'------------------------
'ソケット接続
Private Type sockaddr_in 'ソケットアドレス
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero1 As Long
sin_zero2 As Long
End Type
Private Declare PtrSafe Function socket Lib "ws2_32.dll" (ByVal af As Long, ByVal socktype As Long, ByVal protocol As Long) As Long
Private Declare PtrSafe Function closesocket Lib "ws2_32.dll" (ByVal S As Long) As Long
Private Declare PtrSafe Function connect Lib "ws2_32.dll" (ByVal S As Long, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
Private Declare PtrSafe Function ioctlsocket Lib "ws2_32.dll" (ByVal S As Long, ByVal cmd As Long, argp As LongPtr) As Long
Private Const FIONBIO = &H8004667E
'------------------------
'ソケット送受信
Private Declare PtrSafe Function send Lib "ws2_32.dll" (ByVal S As Long, ByRef buf As Any, ByVal length As Long, ByVal flags As Long) As Long
Private Declare PtrSafe Function strsend Lib "ws2_32.dll" Alias "send" (ByVal S As Long, ByVal buf As String, ByVal length As Long, ByVal flags As Long) As Long
Private Declare PtrSafe Function recv Lib "ws2_32.dll" (ByVal S As Long, ByRef buf As Any, ByVal length As Long, ByVal flags As Long) As Long
Private Declare PtrSafe Function strrecv Lib "ws2_32.dll" Alias "recv" (ByVal S As Long, ByVal buf As String, ByVal length As Long, ByVal flags As Long) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'------------------------
'ウィンドウ関連
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal IpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hWnd As LongPtr, ByVal wFlag As LongPtr) As LongPtr
Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As LongPtr, ByRef lpdwProcessId As LongPtr) As LongPtr
Private Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As LongPtr) As LongPtr
Private Declare PtrSafe Function QueryFullProcessImageName Lib "kernel32" Alias "QueryFullProcessImageNameA" (ByVal hProcess As LongPtr, ByVal dwFlags As Long, ByVal lpExeName As String, ByRef lpdwSize As Long) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As LongPtr
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const GW_HWNDNEXT = &H2
'------------------------
'キーコード送信用API
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As LongPtr, ByVal wparam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As LongPtr, ByVal wMapType As LongPtr) As LongPtr
'------------------------
'モジュールレベル変数
Private Frame() As Byte '通信データを格納するためのフレーム
'-----------メイン処理１-----------
'勤怠（打刻）システムのスタートページを開く
Private Sub Main()
'認証ページ用のID・パスワードを設定
Dim USER_ID As String
Dim PassWord As String
USER_ID = "***********"
PassWord = "***********"
'Edgeプロセスを終了（バックグラウンドも含めてプロセスキル）
With CreateObject("WScript.Shell")
.Run "taskkill /F /IM msedge.exe", 0, True
End With
'リモートデバックポートを使用してEdge起動
Dim edgePath As String
Dim rc As Long
edgePath = Environ("ProgramFiles(x86)") & "\Microsoft\Edge\Application\msedge.exe"
'edgePath = Environ("ProgramFiles") & "\Microsoft\Edge\Application\msedge.exe"
'edgePath = Environ("LOCALAPPDATA") & "\Microsoft\msedge.exe"
rc = Shell(edgePath & " --remote-debugging-port=9222", vbNormalFocus)
'アタッチ可能なターゲット一覧を取得
Dim URL As String
Dim req As Object
Dim resText As String
URL = "http://localhost:9222/json/list" 'Devtools Protocolエンドポイント
Set req = CreateObject("MSXML2.ServerXMLHTTP")
'Set req = CreateObject("MSXML2.XMLHTTP")
'Set req = CreateObject("WinHttp.WinHttpRequest")
req.Open "GET", URL, False
req.setRequestHeader "Content-Type", "application/json"
req.send
resText = req.responseText
Set req = Nothing
'ターゲット一覧から、操作対象のIDを取得（type=pageであるターゲットのid値）
Dim reg As Object
Dim IDs() As String
Dim ID As String
Dim TrimText As String
Set reg = CreateObject("VBScript.RegExp")
With reg
.Pattern = """id"": ""[^""]+"""
.IgnoreCase = True
.Global = True
ReDim IDs(.Execute(resText).Count - 1)
For i = 0 To .Execute(resText).Count - 1
IDs(i) = Mid(resText, .Execute(resText)(i).firstindex + 8, .Execute(resText)(i).length - 8)
If i < .Execute(resText).Count Then
TrimText = Mid(resText, .Execute(resText)(i).firstindex, .Execute(resText)(i).firstindex + 1)
If InStr(TrimText, """type"": ""page""") > 0 Then
ID = IDs(i)
End If
End If
Next i
End With
Set reg = Nothing
'目的ページを開く
Dim CDP_Command As String
Dim response As String
CDP_Command = "{""id"":1, " & _
"""method"":""Page.navigate"", " & _
"""params"":{""url"":""https://www.*********/""}}"
response = WebSocket_Submit(CDP_Command, ID) 'Sub①
'ページ読み込み待機（=Page.loadEventFiredイベントが発生するまで待機）
Dim EverntName As String
CDP_Command = "{""id"":2, " & _
"""method"":""Page.enable""}"
EventName = "Page.loadEventFired"
response = WebSocket_Submit(CDP_Command, ID, EventName)
If response = "" Then End
'If InStr(response, EventName) > 0 Then
' Debug.Print EventName & "イベントを検知しました"
'End If
'ターゲットIDの情報を取得
Dim TimeOutCnt As Integer
response = ""
Do
CDP_Command = "{""id"":3, " & _
"""method"":""Target.getTargets""}"
response = WebSocket_Submit(CDP_Command, ID)
TimeOutCnt = TimeOutCnt + 1
If TimeOutCnt > 10 Then Exit Do
Sleep 500
Loop Until response <> ""
'ログイン認証状況を判別
Dim jsCode As String
If InStr(response, "目的ページが特定できるような一部（URLの一部など）ここに記載") > 0 Then
'Debug.Print "ログイン済みです。ログイン処理はスキップします"
ElseIf InStr(response, "ログインページが特定できるような一部（URLの一部など）をここに記載") > 0 Then
'Debug.Print "未ログインです。続けて処理します"
Sleep 1000 '念のため
Call LogIn(ID, PassWord) 'ログインプロシージャを呼び出してログイン処理を行う
ElseIf InStr(response, "リダイレクト画面が特定できるような一部（UELの一部など）をここに記載") > 0 Then
'Debug.Print "ログイン画面へリダイレクト中です。待機処理します"
TimeOutCnt = 0
Do
CDP_Command = "{""id"":4, " & _
"""method"":""Target.getTargets""}"
response = WebSocket_Submit(CDP_Command, ID)
TimeOutCnt = TimeOutCnt + 1
If TimeOutCnt > 10 Then Exit Do
Sleep 500
Loop Until InStr(response, "リダイレクト画面が特定できるような一部をここに記載") = 0
Sleep 1000 '念のため
Call LogIn(ID, PassWord) 'ログインプロシージャを呼び出してログイン処理を行う
Else
'Debug.Print "想定外エラー。処理中断します" & response
End
End If
'ページ読み込み待機（=Network.loadingFinishedイベントが発生するまで待機）
CDP_Command = "{""id"":11, " & _
"""method"":""Network.enable""}"
EventName = "Network.loadingFinished"
response = WebSocket_Submit(CDP_Command, ID, EventName)
If response = "" Then End
Sleep 1000
'「打刻システムを開く」ボタンを押下
jsCode = "javascript:window.open('http://**********','blank');"
CDP_Command = "{""id"":12, " & _
"""method"":""Runtime.evaluate"", " & _
"""params"":{""expression"":""" & jsCode & """}}"
response = WebSocket_Submit(CDP_Command, ID)
'新しいウィンドウ情報を取得できるまでループ'
'従来ウィンドウ（ログイン後の画面）のターゲットID＝変数ID、新しいウィンドウ（打刻システム画面）のターゲットID=変数NewID
TimeOutCnt = 0
Do
CDP_Command = "{""id"":13, " & _
"""method"":""Target.getTargets""}"
response = WebSocket_Submit(CDP_Command, ID)
Dim TabIDs() As String
Dim NewID As String
Set reg = CreateObject("VBScript.RegExp")
With reg
.Pattern = """targetId"": ""[^""]+"""
.IgnoreCase = True
.Global = True
ReDim TabIDs(.Execute(response).Count - 1)
For i = 0 To .Execute(response).Count - 1
TabIDs(i) = Mid(response, .Execute(response)(i).firstindex + 13, .Execute(response)(i).length - 13)
nEnd = InStr(.Execute(response)(i).firstindex, response, "}")
TrimText = Mid(response, .Execute(response)(i).firstindex, nEnd - .Execute(response)(i).firstindex)
If InStr(TrimText, """page""") > 0 And ID <> TabIDs(i) Then
NewID = TabIDs(i)
Exit Do
End If
Next i
End With
Set reg = Nothing
TimeOutCnt = TimeOutCnt + 1
If TimeOutCnt > 10 Then Exit Do
Sleep 500
Loop Until NewID <> ""
'打刻システムで「打刻」ボタンをクリック
jsCode = "document.getElementsById('****').click();"
CDP_Command = "{""id"":14, " & _
"""method"":""Runtime.evaluate"", " & _
"""params"":{""expression"":""" & jsCode & """}}"
response = WebSocket_Submit(CDP_Command, NewID)
'従来ウィンドウ（ログイン後の画面）を閉じる
CDP_Command = "{""id"":15, " & _
"""method"":""Page.close""}"
response = WebSocket_Submit(CDP_Command, ID)
End Sub
'-----------メイン処理２-----------
’ログイン処理をする
Private Sub LogIn(ByVal pageID As String, PassWord As String)
'「ID資格を保存する」チェックボックスにチェックを入れる
Dim jsCode As String
Dim CDP_Command As String
Dim response As String
jsCode = "document.getElementsById('****').click();"
CDP_Command = "{""id"":5, " & _
"""method"":""Runtime.evaluate"", " & _
"""params"":{""expression"":""" & jsCode & """}}"
response = WebSocket_Submit(CDP_Command, pageID)
'「進む」ボタンをクリック
jsCode = "var button = document.getElementsByTagName('input');" & _
"for (var i = 0; i < button.length; i++) {" & _
" if (button[i].type === 'submit' && button[i].value === '進む') {" & _
" button[i].click();" & _
" break;" & _
" }" & _
"}"
CDP_Command = "{""id"":6, " & _
"""method"":""Runtime.evaluate"", " & _
"""params"":{""expression"":""" & jsCode & """}}"
response = WebSocket_Submit(CDP_Command, pageID)
'ページ読み込み待機（=Page.loadEventFiredイベントが発生するまで待機）
Dim TimeOutCnt As Integer
Dim EverntName As String
TimeOutCnt = 0
Do
CDP_Command = "{""id"":7, " & _
"""method"":""Network.enable""}"
EventName = "Network.loadingFinished"
response = WebSocket_Submit(CDP_Command, pageID, EventName)
'If InStr(response, EventName) > 0 Then
' Debug.Print EventName & "イベントを検知しました"
'End If
If TimeOutCnt > 30 Then Exit Do
Sleep 500
Loop Until InStr(response, "パスワード入力画面が特定できるような一部（URLなど）をここに記載") = 0
'パスワード入力
jsCode = "var textbox = document.getElementsByTagName('input');" & _
"for (var i = 0; i < textbox.length; i++) {" & _
" if (textbox[i].type === 'password') {" & _
" textbox[i].value=" & PassWord & ";" & _
" break;" & _
" }" & _
"}"
CDP_Command = "{""id"":8, " & _
"""method"":""Runtime.evaluate"", " & _
"""params"":{""expression"":""" & jsCode & """}}"
response = WebSocket_Submit(CDP_Command, pageID)
'ユーザー入力を検知するスクリプトを突破する（TABキーを送り込むことで強行突破）
'ブラウザUI部分（ツールバー等）へのフォーカスを回避しつつ、Webページ部分（コンテンツ内容）へのフォーカス状態を強制的に作る
'JavaScriptのfocus()やclick()メソッドが使えるなら、そちらを使用。
'alert()メソッドで一度ダイアログ表示することでブラウザUI部分へのフォーカスを回避。
jsCode = "setTimeout(function(){;" & _
"var img = document.getElementsByTagName('img');" & _
"for (var i = 0; i < img.length; i++) {" & _
" alert(img[0]);" & _
" break;" & _
" }" & _
"}, 100);"
CDP_Command = "{""id"":9, " & _
"""method"":""Runtime.evaluate"", " & _
"""params"":{""expression"":""" & jsCode & """}}"
response = WebSocket_Submit(CDP_Command, pageID)
'-----------メイン処理３-----------
'ウィンドウハンドルを指定して、TabキーとEnterキーを送り込む
Sleep 1000
Dim hWnd As LongPtr
Dim lParam As LongPtr
Const VK_RETURN = &HD 'Enterキー
Const VK_TAB = &H9 'Tabキー
Const WM_KEYDOWN = &H100 'キーDownコード
Do
hWnd = getEdgeWindowHandle 'サブルーチンを呼び出す
Loop Until hWnd <> 0
'ダイアログのOKボタンを押す
lParam = 1 + MapVirtualKey(VK_TAB, 0) * (2 ^ 16)
PostMessage hWnd, WM_KEYDOWN, VK_TAB, lParam
Sleep 1000
lParam = 1 + MapVirtualKey(VK_RETURN, 0) * (2 ^ 16)
PostMessage hWnd, WM_KEYDOWN, VK_RETURN, lParam
Sleep 1500
'パスワード入力用テキストボックスに直接TABキーを送り込む（ユーザー入力検知対策として）
lParam = 1 + MapVirtualKey(VK_TAB, 0) * (2 ^ 16)
PostMessage hWnd, WM_KEYDOWN, VK_TAB, lParam
lParam = 1 + MapVirtualKey(VK_TAB, 0) * (2 ^ 16)
PostMessage hWnd, WM_KEYDOWN, VK_TAB, lParam
'ログインボタンをクリック
jsCode = "var button = document.getElementsByTagName('input');" & _
"for (var i = 0; i < button.length; i++) {" & _
" if (button[i].type === 'submit' && button[i].value === 'ログイン') {" & _
" button[i].click();" & _
" break;" & _
" }" & _
"}"
CDP_Command = "{""id"":10, " & _
"""method"":""Runtime.evaluate"", " & _
"""params"":{""expression"":""" & jsCode & """}}"
response = WebSocket_Submit(CDP_Command, pageID)
End Sub
'-----------メイン処理4-----------
'起動中のEdge上位ウィンドウハンドルを取得して返す
Private Function getEdgeWindowHandle() As LongPtr
'全プロセスの中からプロセス名「msedge.exe」のものを配列WindowInfo()へ格納
Dim hWnd As LongPtr
Dim pId As LongPtr
Dim hProcess As LongPtr
Dim lpExeName As String * 260
Dim lpdwSize As Long
Dim ret As Long
Dim ProcessName As String
Dim WindowInfo() As Variant
Dim Num As Long
Dim strClassName As String * 255
hWnd = FindWindow(vbNullString, vbNullString)
ReDim WindowInfo(3, 0)
Do
If IsWindowVisible(hWnd) <> 0 Then
GetWindowThreadProcessId hWnd, pId 'pId=プロセスID
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, pId)
If hProcess <> 0 Then
lpdwSize = Len(lpExeName)
ret = QueryFullProcessImageName(hProcess, 0, lpExeName, lpdwSize)
If ret <> 0 Then
ProcessName = Mid$(lpExeName, InStrRev(lpExeName, "\") + 1) 'プロセス名
If InStr(ProcessName, "msedge.exe") > 0 Then
ReDim Preserve WindowInfo(3, Num + 1)
WindowInfo(1, Num) = ProcessName
GetClassName hWnd, strClassName, Len(strClassName)
WindowInfo(2, Num) = Left(strClassName, InStr(strClassName, vbNullChar) - 1) 'クラス名
WindowInfo(3, Num) = hWnd
Num = Num + 1
End If
End If
End If
CloseHandle hProcess 'プロセスハンドルを閉じる
End If
hWnd = GetNextWindow(hWnd, GW_HWNDNEXT)
Loop Until hWnd = GetNextWindow(hWnd, GW_HWNDNEXT)
'クラス名「MSCTFIME UI」かつ、２つ先祖（親）のクラス名が「Chrome_WidgetWin_1」であるウィンドウハンドルを特定する
Dim P_hWnd As LongPtr
Dim GP_hWnd As LongPtr
Dim ClassName As String
For i = 0 To UBound(WindowInfo, 2) - 1
If WindowInfo(2, i) = "MSCTFIME UI" Then
P_hWnd = GetParent(WindowInfo(3, i))
GP_hWnd = GetParent(P_hWnd)
GetClassName GP_hWnd, strClassName, Len(strClassName)
ClassName = Left(strClassName, InStr(strClassName, vbNullChar) - 1)
If ClassName = "Chrome_WidgetWin_1" Then
getEdgeWindowHandle = GP_hWnd
Exit Function
End If
End If
Next
End Function
'-----------メイン処理（おわり）----------
'-----------サブルーチン処理----------
Private Function WebSocket_Submit(ByVal CDP_Command As String, ByVal ID As String, Optional ByVal EventName As String) As String 'Sub①
'別記事で紹介。
'「【VBA】Edge標準モードを自動操作（インストール不要）」の記事参照。
End Function
'-----------サブルーチン処理（おわり）----------こんな感じです。
【実装例その２】
１．業務ページを立ち上げる
（ログイン画面に阻まれた場合は、ログイン認証を突破する）
２．業務ページの情報をスクレイピング
（動的生成されたコンテンツ情報も漏らさず情報取得する）
'WSA関連
Private Type WSAData 'ソケット初期化用構造体
wVersion As Integer
wHighVersion As Integer
szDescription As String * 257 'WSA_DESCRIPTIONLEN + 1
szSystemStatus As String * 129 'WSA_SYS_STATUS_LEN + 1
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Private Declare PtrSafe Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequired As Integer, ByRef lpWSAData As WSAData) As Long
Private Declare PtrSafe Function WSACleanup Lib "ws2_32.dll" () As Long
Private Declare PtrSafe Function WSAGetLastError Lib "ws2_32.dll" () As Long
'------------------------
'アドレス取得
Private Declare PtrSafe Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long
Private Declare PtrSafe Function htons Lib "ws2_32.dll" (ByVal hostshort As Long) As Integer
'------------------------
'ソケット接続
Private Type sockaddr_in 'ソケットアドレス
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero1 As Long
sin_zero2 As Long
End Type
Private Declare PtrSafe Function socket Lib "ws2_32.dll" (ByVal af As Long, ByVal socktype As Long, ByVal protocol As Long) As Long
Private Declare PtrSafe Function closesocket Lib "ws2_32.dll" (ByVal S As Long) As Long
Private Declare PtrSafe Function connect Lib "ws2_32.dll" (ByVal S As Long, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
Private Declare PtrSafe Function ioctlsocket Lib "ws2_32.dll" (ByVal S As Long, ByVal cmd As Long, argp As LongPtr) As Long
Private Const FIONBIO = &H8004667E
'------------------------
'ソケット送受信
Private Declare PtrSafe Function send Lib "ws2_32.dll" (ByVal S As Long, ByRef buf As Any, ByVal length As Long, ByVal flags As Long) As Long
Private Declare PtrSafe Function strsend Lib "ws2_32.dll" Alias "send" (ByVal S As Long, ByVal buf As String, ByVal length As Long, ByVal flags As Long) As Long
Private Declare PtrSafe Function recv Lib "ws2_32.dll" (ByVal S As Long, ByRef buf As Any, ByVal length As Long, ByVal flags As Long) As Long
Private Declare PtrSafe Function strrecv Lib "ws2_32.dll" Alias "recv" (ByVal S As Long, ByVal buf As String, ByVal length As Long, ByVal flags As Long) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'モジュールレベル変数
Private Frame() As Byte '通信データを格納するためのフレーム
Private Data() As Variant 'スクレイピング結果を格納する二次元配列
'-----------メイン処理１-----------
Private Sub Main()
'認証ページ用のID・パスワードを設定
Dim USER_ID As String
Dim PASSWORD As String
USER_ID = "***********"
PASSWORD = "***********"
'業務ページを立ち上げる
Dim NewPageID As String
NewPageID = LaunchTargetPage(USER_ID, PASSWORD)
'業務ページをスクレイピングして処理結果をモジュールレベル変数Data()で受取る
Call LetsScraping(NewPageID)
'シートへ書き出す
Dim sh As Worksheet
Set sh = ActiveSheet
sh.Range("A1").Resize(, UBound(Data, 2) + 1).Value = Data
End Sub
'-----------メイン処理２-----------
'業務ページを立ち上げて、そのページのターゲットIDを返す
Private Function LaunchTargetPage(ByVal USER_ID As String, ByVal PASSWORD As String) As String
'Edgeプロセスを強制終了
With CreateObject("WScript.Shell")
.Run "taskkill /F /IM msedge.exe", 0, True
End With
'リモートデバックポートを使用してEdge起動
Dim edgePath As String
Dim rc As Long
edgePath = Environ("ProgramFiles(x86)") & "\Microsoft\Edge\Application\msedge.exe"
'edgePath = Environ("ProgramFiles") & "\Microsoft\Edge\Application\msedge.exe"
'edgePath = Environ("LOCALAPPDATA") & "\Microsoft\msedge.exe"
rc = Shell(edgePath & " --remote-debugging-port=9222", vbNormalFocus)
'アタッチ可能なターゲット一覧を取得
Dim URL As String
Dim req As Object
Dim resText As String
URL = "http://localhost:9222/json/list" 'Devtools Protocolエンドポイント
Set req = CreateObject("MSXML2.ServerXMLHTTP")
'Set req = CreateObject("MSXML2.XMLHTTP")
'Set req = CreateObject("WinHttp.WinHttpRequest")
req.Open "GET", URL, False
req.setRequestHeader "Content-Type", "application/json"
req.send
resText = req.responseText
Set req = Nothing
'ターゲット一覧から、操作対象のIDを取得（type=pageであるターゲットのid値）
Dim reg As Object
Dim IDs() As String
Dim ID As String
Dim nEnd As Long
Dim TrimText As String
Set reg = CreateObject("VBScript.RegExp")
With reg
.Pattern = """id"": ""[^""]+"""
.IgnoreCase = True '大文字小文字を区別しない
.Global = True '全体を検索
ReDim IDs(.Execute(resText).Count - 1)
For i = 0 To .Execute(resText).Count - 1
IDs(i) = Mid(resText, .Execute(resText)(i).firstindex + 8, .Execute(resText)(i).length - 8)
nEnd = InStr(.Execute(resText)(i).firstindex, resText, "}")
TrimText = Mid(resText, .Execute(resText)(i).firstindex, nEnd - .Execute(resText)(i).firstindex)
If InStr(TrimText, """type"": ""page""") > 0 Then
ID = IDs(i)
End If
Next i
End With
Set reg = Nothing
'業務ページ①を開く
Dim CDP_Command As String
Dim response As String
CDP_Command = "{""id"":1, " & _
"""method"":""Page.navigate"", " & _
"""params"":{""url"":""https://www.*********/""}}"
response = WebSocket_Submit(CDP_Command, ID) 'Sub①
'ターゲットIDの情報を取得
Dim TimeOutCnt As Integer
response = ""
Do
CDP_Command = "{""id"":2, " & _
"""method"":""Target.getTargets""}"
response = WebSocket_Submit(CDP_Command, ID)
TimeOutCnt = TimeOutCnt + 1
If TimeOutCnt > 10 Then Exit Do
Sleep 500
Loop Until response <> ""
'ログイン認証状況を判別
Dim jsCode As String
If InStr(response, "業務ページ①が特定できるような一部（URLの一部など）ここに記載") > 0 Then
'Debug.Print "認証済みです。認証処理はスキップします"
ElseIf InStr(response, "認証ページが特定できるような一部（URLの一部など）をここに記載") > 0 Then
'Debug.Print "未認証です。続けて処理します"
jsCode = "var textbox = document.getElementsByTagName('input');" & _
"for (var i = 0; i < textbox.length; i++) {" & _
" if (textbox[i].type === 'text') {" & _
" textbox[i].value=" & USER_ID & ";" & _
" textbox[i+1].value=" & PASSWORD & ";" & _
" textbox[i+2].click();" & _
" break;" & _
" }" & _
"}"
CDP_Command = "{""id"":3, " & _
"""method"":""Runtime.evaluate"", " & _
"""params"":{""expression"":""" & jsCode & """}}"
response = WebSocket_Submit(CDP_Command, ID)
Else
'Debug.Print "想定外エラー。処理中断します" & response
End
End If
'業務ページ②を開く
'（業務ページ①を開いたうえで特定のJavaScriptを実行することで、初めて業務ページ②へアクセス可能になる様なシチュエーションを想定）
jsCode = "javascript:window.open('http://**********','blank');"
CDP_Command = "{""id"":4, " & _
"""method"":""Runtime.evaluate"", " & _
"""params"":{""expression"":""" & jsCode & """}}"
response = WebSocket_Submit(CDP_Command, ID)
'新しいウィンドウ/タブ情報が取得できるまでループ
TimeOutCnt = 0
Do
'新しいウィンドウ/タブを含めたターゲットIDの一覧を取得
CDP_Command = "{""id"":5, " & _
"""method"":""Target.getTargets""}"
response = WebSocket_Submit(CDP_Command, ID)
'従来ウィンドウ/タブ（業務ページ①）のターゲットID（変数ID）、新しいウィンドウ/タブ（業務ページ②）のターゲットID（変数NewID）
Dim TabIDs() As String
Dim NewID As String
Set reg = CreateObject("VBScript.RegExp")
With reg
.Pattern = """targetId"": ""[^""]+"""
.IgnoreCase = True
.Global = True
ReDim TabIDs(.Execute(response).Count - 1)
For i = 0 To .Execute(response).Count - 1
TabIDs(i) = Mid(response, .Execute(response)(i).firstindex + 13, .Execute(response)(i).length - 13)
nEnd = InStr(.Execute(response)(i).firstindex, response, "}")
TrimText = Mid(response, .Execute(response)(i).firstindex, nEnd - .Execute(response)(i).firstindex)
If InStr(TrimText, """page""") > 0 And ID <> TabIDs(i) Then
NewID = TabIDs(i)
Exit Do
End If
Next i
End With
Set reg = Nothing
TimeOutCnt = TimeOutCnt + 1
If TimeOutCnt > 10 Then Exit Do
Sleep 500
Loop Until NewID <> ""
'ページ読み込み待機（=Page.loadEventFiredイベントが発生するまで待機）
CDP_Command = "{""id"":6, " & _
"""method"":""Page.enable""}"
EventName = "Page.loadEventFired"
response = WebSocket_Submit(CDP_Command, NewID, EventName)
'If InStr(response, EventName) > 0 Then
' Debug.Print EventName & "イベントを検知しました"
'End If
Sleep 1000 '念のため
'従来ウィンドウ/タブ（業務ページ①）を閉じる
CDP_Command = "{""id"":7, " & _
"""method"":""Page.close""}"
response = WebSocket_Submit(CDP_Command, ID)
'取得した新しいターゲットIDを返す
LaunchTargetPage = NewID
End Function
'-----------メイン処理３-----------
'業務ページをスクレイピングして、処理結果をモジュールレベル変数Data()へ格納する
Private Sub LetsScraping(ByVal NewPageID As String)
'HTML全体（を含むレスポンス）を取得する
'きちんと情報取得できるまでループ処理（動的に生成されたコンテンツをしっかりスクレイピングするため）
Dim TimeOutCnt As Integer
Dim jsCode As String
Dim CDP_Command As String
Dim response As String
TimeOutCnt = 0
Do
jsCode = "document.documentElement.outerHTML;"
CDP_Command = "{""id"":8, " & _
"""method"":""Runtime.evaluate"", " & _
"""params"":{""expression"":""" & jsCode & """}}"
response = WebSocket_Submit(CDP_Command, NewPageID)
'HTML部分のみを抽出
Dim reg As Object
Dim str As String
Set reg = CreateObject("VBScript.RegExp")
With reg
.Global = False
.Pattern = """value"":""[^""]+"""
str = Mid(response, .Execute(response)(0).firstindex + 10, Len(response) - .Execute(response)(0).firstindex - 11 - 3)
End With
Set reg = Nothing
str = Replace(str, "\""", """")
'モジュールレベルの二次元配列Data()を初期化
ReDim Data(1, 5)
'文字列をHTMLドキュメントへパースして、DOM操作により欲しい情報を特定
Dim tempObj As Object
Dim Elem As Object
Dim CElem As Object
Dim GCElem As Object
Set tempObj = CreateObject("htmlfile")
tempObj.body.innerHTML = str
For Each Elem In tempObj.getElementsByTagName("*****") 'タグ名を入力
If InStr(DecodeStr(Elem.innerText), "●●●") > 0 Then
Data(0, 0) = DecodeStr(Elem.getElementsByTagName("▲▲▲")(0).innerText) '欲しい情報①
End If
If InStr(DecodeStr(Elem.innerText), "□□□") > 0 Then
Data(0, 1) = DecodeStr(Elem.getElementsByTagName("▲▲▲")(1).innerText) '欲しい情報②
End If
If InStr(DecodeStr(Elem.innerText), "×××") > 0 Then
Data(0, 2) = DecodeStr(Elem.getElementsByTagName("▲▲▲")(1).innerText) '欲しい情報③
End If
Next
For Each Elem In tempObj.getElementsByTagName("----------")
If InStr(DecodeStr(Elem.innerText), "〇〇〇") > 0 Then
For Each CElem In Elem.getElementsByTagName("▼▼")
If InStr(DecodeStr(CElem.innerText), "◎◎◎その1") > 0 Then
For Each GCElem In CElem.getElementsByTagName("◆◆")
If GCEleme.innerText <> "" Then
Data(0, 3) = DecodeStr(GCElem.innerText)
End If
Next
ElseIf InStr(DecodeStr(CElem.innerText), "◎◎◎その2") > 0 Then
For Each GCElem In CElem.getElementsByTagName("◆◆")
If GCEleme.innerText <> "" Then
Data(0, 4) = DecodeStr(GCElem.innerText)
End If
Next
End If
Next
End If
Next
Set tempObj = Nothing
teimoutcnt = TimeOutCnt + 1
If TimeOutCnt > 10 Then Exit Do
Sleep 1000
Loop Until Data(0, 0) <> "" And Data(0, 3) <> ""
End Sub
'-----------メイン処理４-----------
'Unicodeエスケープ（\uXXXX形式をデコード）
Private Function DecodeStr(ByVal str As String) As String
Dim reg As Object
Dim str As String
Set reg = CreateObject("VBScript.RegExp")
With reg
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = "\\u([0-9A-Fa-f]{4})"
End With
Dim matches As Object
Dim match As Object
Dim unicodeChar As String
Dim unicodeValue As Long
Set matches = reg.Execute(str)
For Each match In matches
unicodeChar = match.SubMatches(0)
unicodeValue = CLng("&H" & unicodeChar)
str = Replace(str, matche.Value, ChrW("&H" & unicodeChar))
Next
Set reg = Nothing
DecodeStr = str
End Function
'-----------メイン処理（おわり）----------
'-----------サブルーチン処理----------
Private Function WebSocket_Submit(ByVal CDP_Command As String, ByVal ID As String, Optional ByVal EventName As String) As String 'Sub①
'別記事で紹介。
'「【VBA】Edge標準モードを自動操作（インストール不要）」の記事参照。
End Function
'-----------サブルーチン処理（おわり）----------こんな感じです。
実際の業務で使っているVBAコードを手直しして載せたので、タイプミスがあったらごめんなさい。
ポイントは、ウィンドウ/タブが複数に分かれるタイミングや、動的コンテンツが生成されるタイミング（＝生成されるまで待つ処理）など、要所要所でDo - Loop構文でループ処理することで、安定感を高めています。
またCDPのTarget.getTargetsコマンドの実行結果を文字列解析することで、開かれたWebページが「目的のページ」なのか「ログイン認証ページ」なのかを動的に判別しています。
実装例その１では、TABキーを目的の場所（パスワード入力用のテキストボックス）へ送り込むためにちょっとした工夫が必要な場合があります。（詳細はコメントアウト部参照）
実装例その２では、スクレイピングする処理（LetsScrapingプロシージャ部分）では、実際のWebページに対応するように適宜コードを書き換えてください。
JavaScriptの「document.documentElement.outerHTML」を使う事で、スクリプトで書き換わった後のHTMLコンテンツをごっそり情報取得しています。これなら動的に書き換わるWebページであっても、書き換わった後の内容を取得できるので問題ないはずです。
この記事が気に入ったらサポートをしてみませんか？