サンプルブックはこちら↓(解凍パスワード：123)
EdgeIEmode【Pass：123】.zip
(2022/5/27 16:15 微調整 ※関数名を微調整、参照設定3を追記)
弁士さんに感謝(=人=)
Option Explicit
Option Private Module
'【参照設定1】Microsoft Internet Controls
'【参照設定2】Microsoft HTML Object Library
'【参照設定3】Microsoft Scripting Runtime?
Private EnumWindowDic As Scripting.Dictionary
Private EnumChildDocHandle As LongPtr
Private Declare PtrSafe Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function EnumChildWindows Lib "user32" (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassname As String, ByVal nNameLength As Long) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal pString As LongPtr, ByRef pCLSID As Currency) As Long
Private Declare PtrSafe Function RegisterWindowMessageW Lib "user32" (ByVal lpString As LongPtr) As Long
Private Enum SMTO
Normal = 0
BLOCK = 1
ABORTIFHUNG = 2
NOTIMEOUTIFNOTHUNG = 8
End Enum
Private Declare PtrSafe Function SendMessageTimeoutW Lib "user32" (ByVal hWnd As LongPtr, ByVal MSG As Long, ByVal wParam As LongPtr, ByRef lParam As LongPtr, ByVal fuFlags As SMTO, ByVal uTimeout As Long, ByRef lpdwResult As Long) As LongPtr
Private Declare PtrSafe Function ObjectFromLresult Lib "oleacc" (ByVal lResult As Long, ByRef riid As Currency, ByVal wParam As LongPtr, ppvObject As Any) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As Long
Private Declare PtrSafe Function IUnknown_QueryService Lib "shlwapi.dll" (ByVal punk As IUnknown, ByVal guidService As LongPtr, ByVal riid As LongPtr, ByVal ppvOut As LongPtr) As Long
Private Function prSample()
'全てのIEの辞書を取得
Dim Dic_IE As Scripting.Dictionary
Set Dic_IE = fIE_Dic_ALL
If Dic_IE.Count = 0 Then Exit Function
Dim Key As Variant
For Each Key In Dic_IE.Keys
'Key=IEのウィンドウハンドル
Dim hIE As LongPtr
hIE = Key
'IEオブジェクトを辞書から取り出す
Dim IE As InternetExplorer
Set IE = Dic_IE.Item(Key)
' Call IE.Navigate2("https://okwave.jp/qa/q8825108.html")
Next
End Function
Private Function prEdge_Start(URL As String)
'指定URLでEdgeを起動させる
Dim WSH As Object
WSH = CreateObject("WScript.Shell")
Call WSH.Run("msedge.exe" & " " & URL & " " & "-new-window")
End Function
Public Function fIE_Dic_ALL() As Scripting.Dictionary
'旧IEの辞書を作成
Dim Dic_IE As Scripting.Dictionary
Set Dic_IE = prIE_Dic_Old
'IEモードのEdgeのウィンドウハンドルを辞書で取得
Dim Dic_Edge As Scripting.Dictionary
Set Dic_Edge = prIE_Dic_IEmodeEdge
If Dic_Edge.Count > 0 Then
'表示されてるEdgeのウィンドウのハンドルを回し
Dim Key As Variant
For Each Key In Dic_Edge.Keys
Dim hEdge As LongPtr
hEdge = Key
'IEのドキュメントのハンドルを取得
Dim hIEDoc As LongPtr
hIEDoc = Dic_Edge.Item(Key)
'ハンドルからDocumentを取得
Dim Doc As HTMLDocument
Set Doc = prIE_Handle_to_Doc(hIEDoc)
If Doc Is Nothing = False Then
'DocumentからIEを取得
Dim IE As InternetExplorer
Set IE = prIE_from_Doc(Doc)
If IE Is Nothing = False Then
Set Dic_IE.Item(CStr(IE.hWnd)) = IE
End If
End If
Next
End If
Set fIE_Dic_ALL = Dic_IE
End Function
Private Function prIE_Dic_Old(Optional Visible As Boolean = True) As Scripting.Dictionary
Dim Dic As Scripting.Dictionary
Set Dic = New Scripting.Dictionary
'IE,Explorer系のコレクションオブジェクトを生成
'※生成時にコレクション済
Dim Shell As ShellWindows
Set Shell = New ShellWindows
'※権限の異なるIE等が起動されていると、ForEachだとデバッグ発生となるのでForIで対応
Dim i As Long
For i = 1 To Shell.Count
Dim Win As WebBrowser
Set Win = Nothing
On Error Resume Next
Set Win = Shell.Item(i)
On Error GoTo 0
If Win Is Nothing = False Then
With Win
'IEの場合、指定の表示状態だったら、辞書に格納
Dim Name As String
On Error Resume Next
Name = Replace(.FullName, .Path, "")
On Error GoTo 0
If LCase(Name) = LCase("iexplore.exe") Then
If .Visible = Visible Then
Set Dic.Item(CStr(.hWnd)) = Win 'Key:ウィンドウハンドル, Item:IE
End If
End If
End With
End If
Next
Set prIE_Dic_Old = Dic
End Function
Private Function prIE_Dic_IEmodeEdge() As Scripting.Dictionary
'辞書を初期化
Set EnumWindowDic = New Scripting.Dictionary
'トップレベルのウィンドウハンドル全てに対して｢EnumWindowProc｣を実行させる
Call EnumWindows(AddressOf prWindowEnumProc, 1)
'[EnumWindowDic]に溜まった情報を、新規辞書に移し替えて返す
Dim Dic As Scripting.Dictionary
Set Dic = New Scripting.Dictionary
Dim Key As Variant
For Each Key In EnumWindowDic.Keys
Dic.Item(Key) = EnumWindowDic.Item(Key)
Next
Set prIE_Dic_IEmodeEdge = Dic
Set EnumWindowDic = Nothing '解放
End Function
Private Function prWindowEnumProc(ByVal hWnd As LongPtr, ByVal lParam As LongPtr) As Boolean
'トップレベルのウィンドウハンドルのクラス名を取得
Dim ClassName As String
ClassName = prWindowClassName(hWnd)
'ウィンドウのクラスが、ブラウザの場合
'※通常のEdgeの構成は [Chrome_RenderWidgetHostHWND][Chrome_RenderWidgetHostHWND] の2段階のみ
Select Case ClassName
Case "Chrome_WidgetWin_1", "Chrome_WidgetWin_2" '2:最小化時,別タブがアクティブ時
'IEモードのドキュメントのハンドルが取得できたら辞書に貯めておく
Dim hIEDoc As LongPtr
hIEDoc = prIE_DocumentHandle(hWnd)
If hIEDoc <> 0 Then
EnumWindowDic.Item(CStr(hWnd)) = CStr(hIEDoc)
End If
End Select
prWindowEnumProc = True
End Function
Private Function prIE_DocumentHandle(hWnd As LongPtr) As LongPtr
'クリア
EnumChildDocHandle = 0
'子ウィンドウハンドル全てに対して｢EnumChildWindowProc｣を実行させる
Call EnumChildWindows(hWnd, AddressOf prWindowEnumChildProc, 1)
prIE_DocumentHandle = EnumChildDocHandle
End Function
Private Function prWindowEnumChildProc(ByVal hWnd As LongPtr, ByVal lParam As LongPtr) As Boolean
'子ウィンドウのクラス名を取得
Dim ClassName As String
ClassName = prWindowClassName(hWnd)
'ウィンドウのクラスが、IEモードの場合、格納しておく
If ClassName = "Internet Explorer_Server" Then
EnumChildDocHandle = hWnd
End If
prWindowEnumChildProc = True
End Function
Private Function prWindowClassName(hWnd As LongPtr) As String
Dim Class As String
Class = String$(255, 0)
Dim Cnt As Long
Cnt = GetClassName(hWnd, Class, Len(Class))
If Cnt = 0 Then Exit Function
prWindowClassName = Left$(Class, InStr(1, Class, vbNullChar) - 1)
End Function
Private Function prIE_Handle_to_Doc(ByVal hWnd_InternetExplorer_Server As LongPtr, _
Optional ByVal uTimeout As Long = 1000, _
Optional ByVal documentVersion As Integer = 1) As HTMLDocument
' Internet Explorer_Server ウィンドウのハンドルから HTMLDocument オブジェクトを取得する
'
' 第 1 引数: InternetExplorer_Server のウィンドウハンドル
' 第 2 引数: 省略可能(タイムアウト時間)
' 第 3 引数: 省略可能(1:IHTMLDocument～8:IHTMLDocument8)
Dim DocVer As Long
DocVer = documentVersion
If documentVersion <= 0 Then
DocVer = 1
ElseIf documentVersion >= 8 Then
DocVer = 8
End If
Dim Dic_Doc As Scripting.Dictionary
Set Dic_Doc = New Scripting.Dictionary
Dic_Doc.Item(Dic_Doc.Count) = "" '★既定値★
Dic_Doc.Item(Dic_Doc.Count) = "{626FC520-A41E-11cf-A731-00A0C9082637}"
Dic_Doc.Item(Dic_Doc.Count) = "{332c4425-26cb-11d0-b483-00c04fd90119}"
Dic_Doc.Item(Dic_Doc.Count) = "{3050f485-98b5-11cf-bb82-00aa00bdce0b}"
Dic_Doc.Item(Dic_Doc.Count) = "{3050f69a-98b5-11cf-bb82-00aa00bdce0b}"
Dic_Doc.Item(Dic_Doc.Count) = "{3050f80c-98b5-11cf-bb82-00aa00bdce0b}"
Dic_Doc.Item(Dic_Doc.Count) = "{30510417-98b5-11cf-bb82-00aa00bdce0b}"
Dic_Doc.Item(Dic_Doc.Count) = "{305104b8-98b5-11cf-bb82-00aa00bdce0b}"
Dic_Doc.Item(Dic_Doc.Count) = "{305107d0-98b5-11cf-bb82-00aa00bdce0b}"
Dim IID_IHTMLDocumentX As String
IID_IHTMLDocumentX = Dic_Doc.Item(DocVer - 1)
Dim InterfaceId(1) As Currency
Call CLSIDFromString(StrPtr(IID_IHTMLDocumentX), InterfaceId(0))
Dim lngMsg As Long
lngMsg = RegisterWindowMessageW(StrPtr("WM_HTML_GETOBJECT"))
If lngMsg = 0 Then Exit Function
Dim lpdwResult As Long
Dim hRet As LongPtr
hRet = SendMessageTimeoutW(hWnd_InternetExplorer_Server, lngMsg, 0, 0, SMTO.ABORTIFHUNG, uTimeout, lpdwResult)
If hRet = 0 Then Exit Function
Dim Obj As Object
Dim hResult As Long
hResult = ObjectFromLresult(lpdwResult, InterfaceId(0), 0, Obj)
If hResult <> 0 Then Exit Function
If Obj Is Nothing Then Exit Function
Set prIE_Handle_to_Doc = Obj
End Function
Private Function prIE_from_Doc(Doc As HTMLDocument) As InternetExplorer
'IE,DocumentのIIDを取得
Const IKey_IWebBrowserApp As String = "{0002DF05-0000-0000-C000-000000000046}"
Const IKey_IWebBrowser2 As String = "{D30C1661-CDAF-11D0-8A3E-00C04FC9E26E}"
Dim IID_IWebBrowserApp As GUID
Dim IID_IWebBrowser2 As GUID
Dim Ret As Long
Ret = IIDFromString(StrPtr(IKey_IWebBrowserApp), VarPtr(IID_IWebBrowserApp))
Ret = IIDFromString(StrPtr(IKey_IWebBrowser2), VarPtr(IID_IWebBrowser2))
'IHTMLWindow2を基に、IEオブジェクトを取得
' IUnknown_QueryService
' 引数1:IHTMLWindow2 サービスをサポートするCOMオブジェクトのIUnknownインスタンスへのポインター
' 引数2:IID_IWebBrowserApp サービスのユニークな識別子（SID）
' 引数3:IID_IWebBrowser2 目的のサービスインターフェイスのIID
' 引数4:(Ref)IEオブジェクト
Dim IE As InternetExplorer 'APIのByRef戻り値
Ret = IUnknown_QueryService(Doc.parentWindow, VarPtr(IID_IWebBrowserApp), VarPtr(IID_IWebBrowser2), VarPtr(IE))
If IE Is Nothing Then Exit Function
If Ret <> 0 Then Exit Function
'成功したらIEを返す
Set prIE_from_Doc = IE
End Function