IEモードでWeb画面を取得したい！
IEモードでWebスクレイピング
IEでやっていたWebスクレイピングをMicrosoft EdgeのIEモードでできるようにコードを書きました。
個人的にはタブのタイトルでHTMLドキュメントを取得したいので引数はタブタイトルで戻り値はオブジェクトにしました。
Option Explicit
Private Declare Function GetTopWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Function IIDFromString Lib "ole32" (lpsz As Any, lpiid As Any) As Long
Private Declare Function ObjectFromLresult Lib "oleacc" (ByVal lResult As Long, riid As Any, ByVal wParam As Long, ppvObject As Object) As Long
Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
Private Const GW_HWNDNEXT = &H2
Private hIES As Long
Public Function GetWindow(title As String) As Object
Dim con As Object
Dim items As Object
Dim HtmlDoc As Object
Dim hwnd As Long: hwnd = 0
Dim pid As Long: pid = 0
Dim buf As String * 255
Dim ClassName As String
Const ProcessName = "msedge.exe"
Set con = CreateObject("WbemScripting.SWbemLocator").ConnectServer
hwnd = GetTopWindow(0)
Do
GetClassName hwnd, buf, Len(buf)
ClassName = Left(buf, InStr(buf, vbNullChar) - 1)
If InStr(ClassName, "Chrome_WidgetWin_") > 0 Then
'ウィンドウハンドルからプロセスIDを取得し、Edgeのウィンドウかどうかを判別する
GetWindowThreadProcessId hwnd, pid
Set items = con.ExecQuery("Select ProcessId From Win32_Process Where (ProcessId = '" & pid & "') And (Name = '" & ProcessName & "')")
If items.Count > 0 Then
'Edgeの子ウィンドウ列挙
EnumChildWindows hwnd, AddressOf EnumChildProcIES, 0
If hIES <> 0 Then
Set HtmlDoc = GetHTMLDocumentFromIES(hIES)
If HtmlDoc.title like title Then
Set GetWindow = HtmlDoc
Exit Do
End If
End If
End If
End If
hwnd = GetNextWindow(hwnd, GW_HWNDNEXT)
Loop While hwnd <> 0
End Function
Private Function EnumChildProcIES(ByVal hwnd As Long, ByVal lParam As Long) As Long
Dim buf As String * 255
Dim ClassName As String
GetClassName hwnd, buf, Len(buf)
ClassName = Left(buf, InStr(buf, vbNullChar) - 1)
If ClassName = "Internet Explorer_Server" Then
hIES = hwnd
EnumChildProcIES = False
Exit Function
End If
EnumChildProcIES = True
End Function
Private Function GetHTMLDocumentFromIES(ByVal hwnd As Long) As Object
Dim msg As Long, res As Long
Dim iid(0 To 3) As Long
Dim ret As Object, obj As Object
Const SMTO_ABORTIFHUNG = &H2
Const IID_IHTMLDocument2 = "{332C4425-26CB-11D0-B483-00C04FD90119}"
Set ret = Nothing '初期化
msg = RegisterWindowMessage("WM_HTML_GETOBJECT")
SendMessageTimeout hwnd, msg, 0, 0, SMTO_ABORTIFHUNG, 1000, res
If res Then
IIDFromString StrPtr(IID_IHTMLDocument2), iid(0)
If ObjectFromLresult(res, iid(0), 0, obj) = 0 Then Set ret = obj
End If
Set GetHTMLDocumentFromIES = ret
End Function
GetWindow には取得したいウィンドウタイトルの一部分を渡すだけでOK
使用例
例えば、「システム」という文字列を含むウィンドウのHTMLオブジェクトを取得する場合
Dim IeObj As Object
Set IeObj = GetWindow("システム")
Microsoft365Apps対応版
64bit Office で実行する場合はひと手間あるので注意する。
具体的にはptrsafeをつけることとLongをLongPtrにすること
Option Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
Private Declare PtrSafe Function GetTopWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, lpdwProcessId As LongPtr) As LongPtr
Private Declare PtrSafe Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As LongPtr, ByVal msg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr, ByVal fuFlags As LongPtr, ByVal uTimeout As LongPtr, lpdwResult As LongPtr) As LongPtr
Private Declare PtrSafe Function IIDFromString Lib "ole32" (lpsz As Any, lpiid As Any) As Long
Private Declare PtrSafe Function ObjectFromLresult Lib "oleacc" (ByVal lResult As LongPtr, riid As Any, ByVal wParam As LongPtr, ppvObject As Object) As LongPtr
Private Declare PtrSafe Function EnumChildWindows Lib "user32" (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As LongPtr
Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As LongPtr) As LongPtr
Private Const GW_HWNDNEXT = &H2
Private hIES As LongPtr
Public Function GetWindow(Title As String) As Object
Dim con As Object
Dim items As Object
Dim HtmlDoc As Object
Dim hwnd As LongPtr: hwnd = 0
Dim pid As LongPtr: pid = 0
Dim buf As String * 255
Dim ClassName As String
Const ProcessName = "msedge.exe"
Set con = CreateObject("WbemScripting.SWbemLocator").ConnectServer
hwnd = GetTopWindow(0)
Do
GetClassName hwnd, buf, Len(buf)
ClassName = Left(buf, InStr(buf, vbNullChar) - 1)
If InStr(ClassName, "Chrome_WidgetWin_") > 0 Then
'ウィンドウハンドルからプロセスIDを取得し、Edgeのウィンドウかどうかを判別する
GetWindowThreadProcessId hwnd, pid
Set items = con.ExecQuery("Select ProcessId From Win32_Process Where (ProcessId = '" & pid & "') And (Name = '" & ProcessName & "')")
If items.Count > 0 Then
'Edgeの子ウィンドウ列挙
EnumChildWindows hwnd, AddressOf EnumChildProcIES, 0
If hIES <> 0 Then
Set HtmlDoc = GetHTMLDocumentFromIES(hIES)
If HtmlDoc Is Nothing Then
Else
If InStr(HtmlDoc.Title, Title) > 0 Then
Set GetWindow = HtmlDoc
Exit Do
End If
End If
End If
End If
End If
hwnd = GetNextWindow(hwnd, GW_HWNDNEXT)
Loop While hwnd <> 0
End Function
Private Function EnumChildProcIES(ByVal hwnd As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim buf As String * 255
Dim ClassName As String
GetClassName hwnd, buf, Len(buf)
ClassName = Left(buf, InStr(buf, vbNullChar) - 1)
If ClassName = "Internet Explorer_Server" Then
hIES = hwnd
EnumChildProcIES = False
Exit Function
End If
EnumChildProcIES = True
End Function
Private Function GetHTMLDocumentFromIES(ByVal hwnd As LongPtr) As Object
Dim msg As LongPtr, res As LongPtr
Dim iid(0 To 3) As LongPtr
Dim ret As Object, obj As Object
Const SMTO_ABORTIFHUNG = &H2
Const IID_IHTMLDocument2 = "{332c4425-26cb-11d0-b483-00c04fd90119}"
Set ret = Nothing '初期化
msg = RegisterWindowMessage("WM_HTML_GETOBJECT")
SendMessageTimeout hwnd, msg, 0, 0, SMTO_ABORTIFHUNG, 1000, res
If res Then
IIDFromString StrPtr(IID_IHTMLDocument2), iid(0)
If ObjectFromLresult(res, iid(0), 0, obj) = 0 Then Set ret = obj
End If
Set GetHTMLDocumentFromIES = ret
End Function
Tips
IHTMLDocument のIDについて
IHTMLDocmentには8つのバージョンが存在する。
ここに記載したGetWindow は バージョン2を利用した。
| バージョン | ID |
|---|---|
| IHTMLDocument1 | {626FC520-A41E-11cf-A731-00A0C9082637} |
| IHTMLDocument2 | {332c4425-26cb-11d0-b483-00c04fd90119} |
| IHTMLDocument3 | {3050f485-98b5-11cf-bb82-00aa00bdce0b} |
| IHTMLDocument4 | {3050f69a-98b5-11cf-bb82-00aa00bdce0b} |
| IHTMLDocument5 | {3050f80c-98b5-11cf-bb82-00aa00bdce0b} |
| IHTMLDocument6 | {30510417-98b5-11cf-bb82-00aa00bdce0b} |
| IHTMLDocument7 | {305104b8-98b5-11cf-bb82-00aa00bdce0b} |
| IHTMLDocument8 | {305107d0-98b5-11cf-bb82-00aa00bdce0b} |
JavaScriptの活用
IEモードで画面を閉じたいときはJavaScript をうまく利用する。具体的には
ie.DocumentElement.document.Script.setTimeout "javascript: window.open('about:blank','_self').close()"
ポイントはwindow.open('about:blank','_self') で こうすることで
閉じるときに確認画面が表示されるウィンドウも警告なしで閉じることができる。