LoginSignup
2
4

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 1 year has passed since last update.

@harryyuni

VBAでIEモードを操作(Findwindow)

Posted at

EnumWindowsとEnumChildWindowsの合わせ技が重い

　これまでVBAでIE(InternetExplorer)をCOMObjectで動かしてたものをEdgeのIEモードで動くように書き換えています。
　どうしてもWin32API叩くので難易度二回りくらい上がる辛い作業なんですが、割とインターネットで目にする実装はEnumWindowsを使うものが多いです。
　要は、全トップレベルウインドウのウインドウハンドルをEnumWindowsで列挙して、その全子ウインドウをEnumChildWindowsで列挙して、GetClassNameでInternet Explorer_Serverを探すというものです。
　この方法なら、IEモードだけでなくIEのウインドウも拾えるし全ウインドウ列挙するから漏れがなくていいんですが、とにかく重くて処理落ちしていました。もちろん私の職場のPCのスペックの問題もあるのですが。

　そこで、Edge(IEモード)のトップレベルウインドウを判明させれば、少なくともEnumChildWindowsだけで済むんじゃないかと考えました。
　列挙させて調べてみたら、IEモードのトップレベルウインドウは"Chrome_WidgetWin_1"と "Chrome_WidgetWin_2"の２パターンがあり、ウインドウが最小化されていると"Chrome_WidgetWin_2"その他は"Chrome_WidgetWin_1"のようです。
　おまけでIEのトップレベルウインドウは"IEFrame"なので、この３つをFindWindowsで探すように実装してみたところ、ずいぶん軽くなり処理が安定しました。

コード

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function EnumChildWindows Lib "user32" (ByVal hwndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal pString As Long, ByRef pCLSID As Currency) As Long
Private Declare PtrSafe Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare PtrSafe Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByRef lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, ByRef lpdwResult As Long) As Long
Private Declare PtrSafe Function ObjectFromLresult Lib "oleacc" (ByVal lResult As Long, ByRef riid As Any, ByVal wParam As Long, ppvObject As Any) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hWind As Long, ByVal gaFlags As Long) As Long

'htmlの取得
Public Function GetHtmlDocument(ByVal hWnd_InternetExplorer_Server As Long) As Object
    Set GetHtmlDocument = Nothing
    Dim RegWndMsg As Long
    RegWndMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
        If RegWndMsg <> 0 Then
            Dim lpdwResult As Long
            If SendMessageTimeout(hWnd_InternetExplorer_Server, RegWndMsg, 0, 0, 2, 1000, lpdwResult) <> 0 Then
                Dim iId
                Dim hResult As Long
                hResult = ObjectFromLresult(lpdwResult, iId, 0, GetHtmlDocument)
                If hResult <> 0 Then
                    Set GetHtmlDocument = Nothing
                End If
            End If
        End If
End Function
'子ウインドウの列挙
Public Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Object) As Long
    Dim strClassName As String
    strClassName = String(255, vbNullChar)
    GetClassName hWnd, strClassName, Len(strClassName)
    strClassName = RTrim(Left(strClassName, InStr(1, strClassName, vbNullChar) - 1))
    
    Dim hWndArray
    Set hWndArray = lParam
        If Not hWndArray.Exists(hWnd) And strClassName = "Internet Explorer_Server" Then
            hWndArray.Add hWnd, 1
        End If
    EnumChildProc = 1
End Function
'パターン１：namePropかURLで指定したウインドウのHtmlObjectを返す
Function CATCH_WINDOW(urlOrNameProp As String, IsUrl As Boolean) As Object        
    Dim findStringArray As Variant
    findStringArray = Array("IEFrame", "Chrome_WidgetWin_1", "Chrome_WidgetWin_2")
    
    Dim ieTopLvWindowHWndCount As Integer
    ieTopLvWindowHWndCount = -1
    Dim ieTopLvWindowHWndArray() As Long
    Dim ieTopLvWindowHWnd As Long
    Dim findString As Variant
        For Each findString In findStringArray
            ieTopLvWindowHWnd = FindWindow(findString, vbNullString)
                Do While ieTopLvWindowHWnd <> 0
                    ieTopLvWindowHWndCount = ieTopLvWindowHWndCount + 1
                    ReDim Preserve ieTopLvWindowHWndArray(ieTopLvWindowHWndCount)
                    ieTopLvWindowHWndArray(ieTopLvWindowHWndCount) = ieTopLvWindowHWnd
                    ieTopLvWindowHWnd = FindWindowEx(0, ieTopLvWindowHWnd, findString, vbNullString)
                Loop
        Next findString
    Dim ieHWndArray As Object
    Set ieHWndArray = CreateObject("Scripting.Dictionary")
        Dim hWnd As Variant
        For Each hWnd In ieTopLvWindowHWndArray
            Call EnumChildWindows(hWnd, AddressOf EnumChildProc, ObjPtr(ieHWndArray))
        Next hWnd
           
    Dim IsWindowBeing As Boolean
    IsWindowBeing = False
    Dim htmlDoc As Object
    Dim wndKey
        For Each wndKey In ieHWndArray.Keys
            Set htmlDoc = GetHtmlDocument(wndKey)
                If Not htmlDoc Is Nothing Then
                    Dim htmlDocUrl As String
                    htmlDocUrl = htmlDoc.url
                    Dim htmlDocNameProp As String
                    htmlDocNameProp = htmlDoc.nameProp
                        If IsUrl = True And InStr(htmlDocUrl, urlOrNameProp) > 0 Then
                            Set CATCH_WINDOW = htmlDoc
                            IsWindowBeing = True
                            Exit For
                        ElseIf IsUrl = False And htmlDocNameProp = urlOrNameProp Then
                            Set CATCH_WINDOW = htmlDoc
                            IsWindowBeing = True
                            Exit For
                        End If
                    End If
        Next wndKey
        
        If IsWindowBeing = False Then
            Set CATCH_WINDOW = Nothing
        End If
End Function
'パターン２：namePropとトップレベルウインドウの配列を渡して重複しないウインドウハンドルを返す
Function CATCH_ANOTHER_WINDOW_HANDLE(nameProp As String, topLvHWndArray As Object)
    CATCH_ANOTHER_WINDOW_HANDLE = 0
    Dim findStringArray As Variant
    findStringArray = Array("IEFrame", "Chrome_WidgetWin_1", "Chrome_WidgetWin_2")
    
    Dim currentIeTopLvHWndArray As Object
    Set currentIeTopLvHWndArray = CreateObject("Scripting.Dictionary")
    Dim ieTopLvWindowHWnd As Long
    Dim findString As Variant
        For Each findString In findStringArray
            ieTopLvWindowHWnd = FindWindow(findString, vbNullString)
                Do While ieTopLvWindowHWnd <> 0
                        If Not topLvHWndArray.Exists(ieTopLvWindowHWnd) Then
                            currentIeTopLvHWndArray.Add ieTopLvWindowHWnd, 1
                        End If
                    ieTopLvWindowHWnd = FindWindowEx(0, ieTopLvWindowHWnd, findString, vbNullString)
                Loop
        Next findString
    Dim ieHWndArray As Object
    Set ieHWndArray = CreateObject("Scripting.Dictionary")
        Dim hWnd As Variant
        For Each hWnd In currentIeTopLvHWndArray.Keys
            Call EnumChildWindows(hWnd, AddressOf EnumChildProc, ObjPtr(ieHWndArray))
        Next hWnd
    
    Dim htmlDoc As Object
    Dim wndKey
        For Each wndKey In ieHWndArray.Keys
            Set htmlDoc = GetHtmlDocument(wndKey)
                If Not htmlDoc Is Nothing Then
                    Dim htmlDocNameProp As String
                    htmlDocNameProp = htmlDoc.nameProp
                        If htmlDocNameProp = nameProp Then
                            CATCH_ANOTHER_WINDOW_HANDLE = wndKey
                            Exit For
                        End If
                End If
        Next wndKey
End Function

'IEモードのウインドウハンドルを取得する(パターン１：CATCH_WINDOW)
sub main1()
    Dim searchHtmldoc As Object
    Set searchHtmldoc = CATCH_ANOTHER_WINDOW("●取得したいウインドウのnamePropかURL●",URLのときTrue,namePropのときFalse)
end sub

'ウインドウハンドルを取得する(配列にトップレベルウインドウのないもの、パターン２：CATCH_ANOTHER_WINDOW_HANDLE)
sub main2()
    Dim topLvSearchHWndArray As Object
    Set topLvSearchHWndArray = CreateObject("Scripting.Dictionary")
    Dim searchHwnd As Long
    searchHwnd = 0
    searchHwnd = CATCH_ANOTHER_WINDOW_HANDLE("●取得したいウインドウのnameProp●", topLvSearchHWndArray)
    topLvSearchHWndArray.Add GetAncestor(searchHwnd, 2), 1
    Dim searchHtmldoc As Object
    Set searchHtmldoc = GetHtmlDocument(searchHwnd)

'ボタンを押した後など画面遷移後に新しい画面を取得するときはループ処理
          Dim t As Byte
                For t = 1 To 10
                    If searchHwnd <> 0 Then
                        Exit For
                    Else
                        searchHwnd = CATCH_ANOTHER_WINDOW_HANDLE("●取得したいウインドウのnameProp●", topLvSearchHWndArray)
                        Application.Wait Now() + TimeValue("00:00:01")
                    End If
                Next t
'閉じるとき
    PostMessage GetAncestor(searchHwnd, 2), 16, 0, 0
End Sub

説明

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function EnumChildWindows Lib "user32" (ByVal hwndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal pString As Long, ByRef pCLSID As Currency) As Long
Private Declare PtrSafe Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare PtrSafe Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByRef lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, ByRef lpdwResult As Long) As Long
Private Declare PtrSafe Function ObjectFromLresult Lib "oleacc" (ByVal lResult As Long, ByRef riid As Any, ByVal wParam As Long, ppvObject As Any) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hWind As Long, ByVal gaFlags As Long) As Long

　まずは宣言です。これがないとAPIは動きません。privateにしたなら別モジュールのマクロでAPI使えないので、基本的にはこのモジュールにAPIを使うプロシージャをまとめることになります。publicにするのも手ですが、突然APIが出現するコードは、たぶん初見殺しになります。
　ハンドルで細かく操作する際は重複を避けるときや閉じたりするときトップレベルウインドウを操作すると便利なので、GetAncestorを宣言しておきます。

'htmlの取得
Public Function GetHtmlDocument(ByVal hWnd_InternetExplorer_Server As Long) As Object
    Set GetHtmlDocument = Nothing
    Dim RegWndMsg As Long
    RegWndMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
        If RegWndMsg <> 0 Then
            Dim lpdwResult As Long
            If SendMessageTimeout(hWnd_InternetExplorer_Server, RegWndMsg, 0, 0, 2, 1000, lpdwResult) <> 0 Then
                Dim iId
                Dim hResult As Long
                hResult = ObjectFromLresult(lpdwResult, iId, 0, GetHtmlDocument)
                If hResult <> 0 Then
                    Set GetHtmlDocument = Nothing
                End If
            End If
        End If
End Function

htmlの取得はhResultが失敗したときにErr.Raise hResultでエラーコードを出力するコードを見ますが、実際には出力できずにそれ自体がエラーになるので、Nothingにして呼び出し側で制御しています。

'パターン１：namePropかURLで指定したウインドウのHtmlObjectを返す
Function CATCH_WINDOW(urlOrNameProp As String, IsUrl As Boolean) As Object        
    Dim findStringArray As Variant
    findStringArray = Array("IEFrame", "Chrome_WidgetWin_1", "Chrome_WidgetWin_2")
    
    Dim ieTopLvWindowHWndCount As Integer
    ieTopLvWindowHWndCount = -1
    Dim ieTopLvWindowHWndArray() As Long
    Dim ieTopLvWindowHWnd As Long
    Dim findString As Variant
        For Each findString In findStringArray
            ieTopLvWindowHWnd = FindWindow(findString, vbNullString)
                Do While ieTopLvWindowHWnd <> 0
                    ieTopLvWindowHWndCount = ieTopLvWindowHWndCount + 1
                    ReDim Preserve ieTopLvWindowHWndArray(ieTopLvWindowHWndCount)
                    ieTopLvWindowHWndArray(ieTopLvWindowHWndCount) = ieTopLvWindowHWnd
                    ieTopLvWindowHWnd = FindWindowEx(0, ieTopLvWindowHWnd, findString, vbNullString)
                Loop
        Next findString
    Dim ieHWndArray As Object
    Set ieHWndArray = CreateObject("Scripting.Dictionary")
        Dim hWnd As Variant
        For Each hWnd In ieTopLvWindowHWndArray
            Call EnumChildWindows(hWnd, AddressOf EnumChildProc, ObjPtr(ieHWndArray))
        Next hWnd
           
    Dim IsWindowBeing As Boolean
    IsWindowBeing = False
    Dim htmlDoc As Object
    Dim wndKey
        For Each wndKey In ieHWndArray.Keys
            Set htmlDoc = GetHtmlDocument(wndKey)
                If Not htmlDoc Is Nothing Then
                    Dim htmlDocUrl As String
                    htmlDocUrl = htmlDoc.url
                    Dim htmlDocNameProp As String
                    htmlDocNameProp = htmlDoc.nameProp
                        If IsUrl = True And InStr(htmlDocUrl, urlOrNameProp) > 0 Then
                            Set CATCH_WINDOW = htmlDoc
                            IsWindowBeing = True
                            Exit For
                        ElseIf IsUrl = False And htmlDocNameProp = urlOrNameProp Then
                            Set CATCH_WINDOW = htmlDoc
                            IsWindowBeing = True
                            Exit For
                        End If
                    End If
        Next wndKey
        
        If IsWindowBeing = False Then
            Set CATCH_WINDOW = Nothing
        End If
End Function
  • namePropはIE(Comobject)のLocationName
  • URLはIE(Comobject)のLocationURL
    を設定すれば動くように作っています。
    　
    　画面を捕まえて入力などさせるだけならこれで十分です。
    　画面を閉じたり複数の中から見つけたりという操作をするのであれば、メインのプロシージャでハンドルを拾えるようにする必要があるのでパターン２を使います。
'パターン２：namePropとトップレベルウインドウの配列を渡して重複しないウインドウハンドルを返す
Function CATCH_ANOTHER_WINDOW_HANDLE(nameProp As String, topLvHWndArray As Object)
    CATCH_ANOTHER_WINDOW_HANDLE = 0
    Dim findStringArray As Variant
    findStringArray = Array("IEFrame", "Chrome_WidgetWin_1", "Chrome_WidgetWin_2")
    
    Dim currentIeTopLvHWndArray As Object
    Set currentIeTopLvHWndArray = CreateObject("Scripting.Dictionary")
    Dim ieTopLvWindowHWnd As Long
    Dim findString As Variant
        For Each findString In findStringArray
            ieTopLvWindowHWnd = FindWindow(findString, vbNullString)
                Do While ieTopLvWindowHWnd <> 0
                        If Not topLvHWndArray.Exists(ieTopLvWindowHWnd) Then
                            currentIeTopLvHWndArray.Add ieTopLvWindowHWnd, 1
                        End If
                    ieTopLvWindowHWnd = FindWindowEx(0, ieTopLvWindowHWnd, findString, vbNullString)
                Loop
        Next findString
    Dim ieHWndArray As Object
    Set ieHWndArray = CreateObject("Scripting.Dictionary")
        Dim hWnd As Variant
        For Each hWnd In currentIeTopLvHWndArray.Keys
            Call EnumChildWindows(hWnd, AddressOf EnumChildProc, ObjPtr(ieHWndArray))
        Next hWnd
    
    Dim htmlDoc As Object
    Dim wndKey
        For Each wndKey In ieHWndArray.Keys
            Set htmlDoc = GetHtmlDocument(wndKey)
                If Not htmlDoc Is Nothing Then
                    Dim htmlDocNameProp As String
                    htmlDocNameProp = htmlDoc.nameProp
                        If htmlDocNameProp = nameProp Then
                            CATCH_ANOTHER_WINDOW_HANDLE = wndKey
                            Exit For
                        End If
                End If
        Next wndKey
End Function

'ウインドウハンドルを取得する(パターン２：CATCH_ANOTHER_WINDOW_HANDLE)
sub main2()
    Dim topLvSearchHWndArray As Object
    Set topLvSearchHWndArray = CreateObject("Scripting.Dictionary")
    Dim searchHwnd As Long
    searchHwnd = 0
    searchHwnd = CATCH_ANOTHER_WINDOW_HANDLE("●取得したいウインドウのnameProp●", topLvSearchHWndArray)
    topLvSearchHWndArray.Add GetAncestor(searchHwnd, 2), 1
    Dim searchHtmldoc As Object
    Set searchHtmldoc = GetHtmlDocument(searchHwnd)

'ボタンを押した後など画面遷移後に新しい画面を取得するときはループ処理
          Dim t As Byte
                For t = 1 To 10
                    If searchHwnd <> 0 Then
                        Exit For
                    Else
                        searchHwnd = CATCH_ANOTHER_WINDOW_HANDLE("●取得したいウインドウのnameProp●", topLvSearchHWndArray)
                        Application.Wait Now() + TimeValue("00:00:01")
                    End If
                Next t

　namePropは新しいページを開くと同じになることが多く、その場合に前に開いたウインドウを区別するためにハンドルを取得します。
トップレベルウインドウをtopLvSearchHWndArrayに入れていくことで、それとは違うウインドウを探して見つけます。
　複数タブで増やしていくときはトップレベルウインドウではなくてIEモードのウインドウを配列にした方がよいかもしれません。

'閉じるとき
    PostMessage GetAncestor(searchHwnd, 2), 16, 0, 0
End Sub

　IEモードのウインドウのみを閉じると，複数タブを開いているときはいいのですが、そのエッジでそのタブしかないときは空のウインドウがのこるので、GetAncestorでトップレベルウインドウのハンドルを呼んで閉じています。

2
4
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
2
4

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?