LoginSignup
0
1
@hotaru_0319

VBA ブラウザ操作（参照不可）

Last updated at Posted at 2024-01-31

以下に、VBAコードの一部を追加してブラウザ（Microsoft Edge）のIEモードを操作するサブルーチンを完成させます。サブルーチンは、指定したタイトルのIEモードウィンドウのハンドルを取得し、そのウィンドウをDOM化（HTMLDocument2オブジェクトを生成）します。

Option Explicit

' ... (既存のコード)

'-----------サブルーチン処理----------
Sub Get_IES_hWnd(ByVal Title As String) 'Sub①
    Dim hWndParent As LongPtr
    hWndParent = FindWindow(vbNullString, Title)
    
    If hWndParent <> 0 Then
        EnumChildWindows hWndParent, AddressOf EnumChildProc, 0
    Else
        IES_hWnd = 0
    End If
End Sub

Private Function EnumChildProc(ByVal hwnd As LongPtr, ByVal lParam As Long) As Long
    Dim clsName As String * 256
    Dim txt As String * 256
    
    If IsWindowVisible(hwnd) Then
        GetClassName hwnd, clsName, Len(clsName)
        GetWindowText hwnd, txt, Len(txt)
        
        If InStr(1, clsName, "Internet_Explorer_Server", vbTextCompare) > 0 Then
            IES_hWnd = hwnd
            EnumChildProc = 0
        Else
            EnumChildProc = 1
        End If
    Else
        EnumChildProc = 1
    End If
End Function

Private Sub Get_HTMLDocument(ByVal IES_hWnd As LongPtr) 'Sub②
    If IES_hWnd <> 0 Then
        Dim lMsg As LongPtr
        Dim lResult As LongPtr
        Dim IID_IHTMLDocument2 As GUID
        
        ' Register the message
        lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
        
        ' Get the IHTMLDocument2 interface
        SendMessageTimeout IES_hWnd, lMsg, 0, 0, SMTO_ABORTIFHUNG, 1000, lResult
        
        If lResult <> 0 Then
            Call ObjectFromLresult(lResult, IID_IHTMLDocument2, 0, objEdge)
        End If
    End If
End Sub
'-----------サブルーチン処理（おわり）----------

上記のコードでは、Get_IES_hWndサブルーチンでは、指定したタイトルの親ウィンドウ（IEモードウィンドウ）のハンドルを取得し、その親ウィンドウ内でEnumChildProcサブルーチンを呼び出してInternet Explorerのウィンドウハンドルを特定しています。Get_HTMLDocumentサブルーチンでは、特定されたIEモードウィンドウのハンドルからIHTMLDocument2オブジェクトを取得しています。これにより、後続のブラウザ操作が可能になります。

また、上記のコードでは、FindWindow関数を使用して指定したタイトルのウィンドウのハンドルを取得しています。FindWindow関数は、指定されたクラス名およびウィンドウ名に一致する最初のトップレベルウィンドウまたは子ウィンドウのハンドルを返します。

申し訳ありません。FindWindow関数が未定義のエラーが発生しているようです。これは、FindWindow関数がuser32.dllからインポートされていないためです。以下に、必要な部分を追加した修正コードを示します。

Option Explicit

' ... (既存のコード)

' WinAPI関連
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

'-----------サブルーチン処理----------
Sub Get_IES_hWnd(ByVal Title As String) 'Sub①
    Dim hWndParent As LongPtr
    hWndParent = FindWindow(vbNullString, Title)
    
    If hWndParent <> 0 Then
        EnumChildWindows hWndParent, AddressOf EnumChildProc, 0
    Else
        IES_hWnd = 0
    End If
End Sub

' ... (既存のコード)

上記の修正コードでは、FindWindow関数の宣言を追加しています。これにより、FindWindow関数を使用して指定したタイトルのウィンドウのハンドルを正しく取得できるようになります。

以下に、補足を踏まえた修正を加えたコードを提供します。このコードは、「InternetExplorer_Server」クラス名のウィンドウを見つけ、そのウィンドウハンドルを取得し、それをIHTMLDocument2に変換しています。

Option Explicit

' ... (既存のコード)

' WinAPI関連
Private Declare PtrSafe Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByVal lParam As Long) As Long
Private Declare PtrSafe Function EnumChildWindows Lib "user32.dll" (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, lParam As Long) As Long
Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) 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 LongPtr, ByVal msg As Long, _
    ByVal wParam As LongPtr, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare PtrSafe Function ObjectFromLresult Lib "oleacc" (ByVal lResult As Long, riid As Any, ByVal wParam As Long, ppvObject As Object) As Long

' ... (モジュール変数宣言)

'-----------サブルーチン処理----------
Sub Get_IES_hWnd(ByVal Title As String) 'Sub①
    Num = 0
    ReDim hWnds(0)
    EnumWindows AddressOf EnumWindowsProc, 0
    If Num > 0 Then
        For i = 0 To Num - 1
            Call GetWinText(hWnds(i), Title)
            If InStr(1, Title, "google", vbTextCompare) > 0 Then
                IES_hWnd = hWnds(i)
                Exit For
            End If
        Next i
    End If
End Sub

Private Function EnumWindowsProc(ByVal hWndX As LongPtr, ByVal lParam As Long) As Long
    If IsWindowVisible(hWndX) Then
        Num = Num + 1
        ReDim Preserve hWnds(Num)
        hWnds(Num - 1) = hWndX
    End If
    EnumWindowsProc = 1
End Function

Private Sub GetWinText(ByVal hWndY As LongPtr, ByVal Title As String)
    Dim clsName As String * 256
    GetClassName hWndY, clsName, Len(clsName)
    If InStr(1, clsName, "Internet Explorer_Server", vbTextCompare) > 0 Then
        GetWindowText hWndY, Title, Len(Title)
    End If
End Sub

Private Sub Get_HTMLDocument(ByVal IES_hWnd As LongPtr) 'Sub②
    If IES_hWnd <> 0 Then
        Dim lMsg As Long
        Dim lResult As Long
        Dim IID_IHTMLDocument2 As GUID
        
        ' Register the message
        lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
        
        ' Get the IHTMLDocument2 interface
        SendMessageTimeout IES_hWnd, lMsg, 0, 0, SMTO_ABORTIFHUNG, 1000, lResult
        
        If lResult <> 0 Then
            Call ObjectFromLresult(lResult, IID_IHTMLDocument2, 0, objEdge)
        End If
    End If
End Sub

' ... (メイン処理)

' ... (その他必要なコード)

上記の修正では、EnumWindows関数を使用して最上位ウィンドウを列挙し、EnumWindowsProcコールバック関数でウィンドウの可視性を確認し、「Internet Explorer_Server」クラス名を持つウィンドウを探します。見つかったウィンドウのハンドルをhWnds配列に保存し、その後GetWinText関数でウィンドウのキャプションを取得しています。最終的に、指定したタイトルを含むウィンドウが見つかれば、そのハンドルをIES_hWndに代入します。

このエラーが発生する原因は、objEdgeが正しく設定されていない可能性があります。つまり、objEdgeにIHTMLDocument2オブジェクトが代入されていないか、何らかの理由で解放されてしまっている可能性があります。

修正の一環として、objEdgeがNothingでないことを確認し、objEdgeが正しく設定されている場合にのみgetElementsByNameメソッドを呼び出すようにしましょう。以下に修正例を示します。

' 対象ページ操作
If Not objEdge Is Nothing Then
    objEdge.getElementsByName("q")(0).Value = "地獄の油揚げ"
    For Each button In objEdge.getElementsByTagName("input")
        If button.Type = "submit" Then
            button.Click
            Exit For
        End If
    Next
    Debug.Print "ブラウザ操作完了"
Else
    MsgBox "IHTMLDocument2オブジェクトが正しく設定されていません。"
End If

この修正により、objEdgeがNothingであればメッセージボックスが表示され、それ以外の場合は操作が行われるようになります。エラーの根本的な原因は、objEdgeの設定が正しく行われていないことなので、それに対処する必要があります。適切なタイミングでobjEdgeにIHTMLDocument2オブジェクトを設定することが重要です。

↓IHTMLDocument2の取得エラー修正
コードを確認した結果、問題が特定されました。ObjectFromLresult関数の宣言において、IID_IHTMLDocument2の型がGUID型であることに起因しています。正しくは、IID_IHTMLDocument2をIID_IUnknown型として宣言する必要があります。

以下が修正されたコードです。

Option Explicit

' ... (既存のコード)

Private Declare PtrSafe Function ObjectFromLresult Lib "oleacc" (ByVal lResult As LongPtr, riid As IID_IUnknown, ByVal wParam As LongPtr, ppvObject As Object) As LongPtr

' ... (既存のコード)

Private Sub Get_HTMLDocument(ByVal IES_hWnd As LongPtr) 'Sub②
    If IES_hWnd <> 0 Then
        Dim lMsg As Long
        Dim lResult As LongPtr
        Dim IID_IHTMLDocument2 As IID_IUnknown
        
        ' Register the message
        lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
        
        ' Get the IHTMLDocument2 interface
        SendMessageTimeout IES_hWnd, lMsg, 0, 0, SMTO_ABORTIFHUNG, 1000, lResult
        
        If lResult <> 0 Then
            Call ObjectFromLresult(lResult, IID_IHTMLDocument2, 0, objEdge)
        End If
    End If
End Sub

修正点は、IID_IHTMLDocument2をIID_IUnknown型に変更した部分です。ObjectFromLresult関数の第二引数は、要求されるインターフェースの型を指定する必要があります。IHTMLDocument2はIUnknownを継承しているため、IID_IUnknownを使用します。これにより、ObjectFromLresult関数が正しくIHTMLDocument2オブジェクトを取得できるようになります。

↓追加の修正
申し訳ありませんが、型の不一致が解消できていないようです。IID_IUnknownの代わりに、IID_IHTMLDocument2を明示的に宣言することが必要です。

以下が修正されたコードです。

Option Explicit

' ... (既存のコード)

Private Type IID_IHTMLDocument2
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Declare PtrSafe Function ObjectFromLresult Lib "oleacc" (ByVal lResult As LongPtr, ByRef riid As IID_IHTMLDocument2, ByVal wParam As LongPtr, ppvObject As Object) As LongPtr

' ... (既存のコード)

Private Sub Get_HTMLDocument(ByVal IES_hWnd As LongPtr) 'Sub②
    If IES_hWnd <> 0 Then
        Dim lMsg As Long
        Dim lResult As LongPtr
        Dim IID_IHTMLDocument2 As IID_IHTMLDocument2
        
        ' Register the message
        lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
        
        ' Get the IHTMLDocument2 interface
        SendMessageTimeout IES_hWnd, lMsg, 0, 0, SMTO_ABORTIFHUNG, 1000, lResult
        
        If lResult <> 0 Then
            Call ObjectFromLresult(lResult, IID_IHTMLDocument2, 0, objEdge)
        End If
    End If
End Sub

上記の修正で、IID_IHTMLDocument2型を正しく使用できるようになるはずです。お手数ですが、この修正をお試しいただき、問題が解消されているか確認してください。

↓追加の修正

もし riid の型が IID_IHTMLDocument2 に適しているにもかかわらず、エラーが発生している場合、以下の点を確認してみてください。

  1. IID_IHTMLDocument2 の宣言が正確であるか確認する:

    • IID_IHTMLDocument2 の宣言が正確であり、かつ ObjectFromLresult 関数の呼び出し時に riid に正しく渡されていることを確認します。

  2. objEdge 変数の初期化:

    • ObjectFromLresult 関数が呼ばれる前に objEdge 変数が初期化されていることを確認します。もし初期化されていない場合、Nothing を ObjectFromLresult 関数に渡すことになり、エラーが発生します。

  3. COM オブジェクトの解放:

    • objEdge 変数が以前の呼び出しからの参照を保持していないことを確認します。COM オブジェクトは参照を解放しない限りメモリに残ります。objEdge 変数が以前の IHTMLDocument2 インターフェースを保持している場合、新しいインターフェースの取得でエラーが発生する可能性があります。

  4. コードの他の部分を確認:

    • Get_HTMLDocument プロシージャが適切に呼ばれ、IES_hWnd が正しいウィンドウハンドルを持っていることを確認してください。

以下は修正例です。これにより、objEdge 変数が初期化され、ObjectFromLresult 関数が正しい IID_IHTMLDocument2 を期待するようになります。

Private Sub Get_HTMLDocument(ByVal IES_hWnd As LongPtr) 'Sub②
    If IES_hWnd <> 0 Then
        Dim lMsg As Long
        Dim lResult As LongPtr
        Dim IID_IHTMLDocument2 As IID_IUnknown
        
        ' Initialize objEdge
        Set objEdge = Nothing
        
        ' Register the message
        lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
        
        ' Get the IHTMLDocument2 interface
        SendMessageTimeout IES_hWnd, lMsg, 0, 0, SMTO_ABORTIFHUNG, 1000, lResult
        
        If lResult <> 0 Then
            Call ObjectFromLresult(lResult, IID_IHTMLDocument2, 0, objEdge)
        End If
    End If
End Sub

もし問題が解決しない場合、エラーメッセージやエラーコードが提供されていれば、それを共有いただければと思います。

Option Explicit

'プロセス監視用API
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 CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function WaitForInputIdle Lib "user32" (ByVal hProcess As LongPtr, ByVal dwMilliseconds As Long) As LongPtr
Private Const SYNCHRONIZE As Long = &H100000
Private Const INFINITE As Long = &HFFFF
'------------------------
'ウィンドウ情報（ハンドル・キャプション名・クラス名）取得用API
Private Declare PtrSafe Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByVal lParam As Long) As Long
Private Declare PtrSafe Function EnumChildWindows Lib "user32.dll" (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, lParam As Long) As Long
Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As LongPtr) As LongPtr
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hWnd As LongPtr) 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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As LongPtr
Private Const GW_HWNDNEXT = &H2
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
'------------------------
'Edge画面DOM取得用API
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 ObjectFromLresult Lib "oleacc" (ByVal lResult As LongPtr, riid As Any, ByVal wParam As LongPtr, ppvObject As Object) As LongPtr
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Const SMTO_ABORTIFHUNG = &H2
'------------------------
'Edge画面操作用API
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
'------------------------
'モジュール変数
Private Title As String
Private hWnd As LongPtr
Private IES_hWnd As LongPtr 'クラス名「Internet_Explorer_Server」のハンドル
Private Num As Integer  'ウィンドウハンドル要素数
Private hWnds() As LongPtr 'ウィンドウハンドル配列
Private objEdge As Object 'mshtml.IHTMLDocument2   'IES_hWndウィンドウをDOM化(HTMLDocument化)したオブジェクト




'-----------メイン処理-----------
Private Sub Sample()

    'ブラウザ起動＆プロセス監視（入力受付状態になるまで待つ）
    Dim URL As String
    Dim rc As LongPtr
    Dim ProchWnd As LongPtr
    URL = "https://www.google.co.jp/" '←任意のURLに変えて　　
    rc = Shell(Environ("ProgramFiles(x86)") & "\Microsoft\Edge\Application\msedge.exe " & URL, vbNormalFocus)
    'rc = Shell(Environ("ProgramFiles") & "\Microsoft\Edge\Application\msedge.exe " & URL, vbNormalFocus)
    'rc = Shell(Environ("LOCALAPPDATA") & "\Microsoft\msedge.exe " & URL, vbNormalFocus)
    Sleep 500
    ProchWnd = OpenProcess(SYNCHRONZE, 0&, rc)
    If ProchWnd <> 0 Then
        Call WaitForInputIdle(ProchWnd, INFINITE)
    End If
    Call CloseHandle(ProchWnd)
    Debug.Print "Edge立上げ完了"

    'ページ読み込み待ち
    Dim TimeOutCnt As Integer
    TimeOutCnt = 0
    Do
        Sleep 2000
        Title = "Google"
        Call Get_IES_hWnd(Title) 'Sub①
        TimeOutCnt = TimeOutCnt + 1
        If TimeOutCnt > 5 Then
            MsgBox "タイムアウト"
            End
        End If
    Loop While IES_hWnd = 0
    Debug.Print "ページ読み込み完了"
    
    'HTMLDocument2オブジェクト生成
    Call Get_HTMLDocument(IES_hWnd) 'Sub②
    
    '対象ページ操作
    objEdge.getElementsByName("q")(0).Value = "地獄の油揚げ"
    For Each button In objEdge.getElementsByTagName("input")
    If button.Type = "submit" Then
        button.Click
        Exit For
    End If
    Next
    Debug.Print "ブラウザ操作完了"

End Sub
'-----------メイン処理（おわり）-----------

'-----------サブルーチン処理----------
Sub Get_IES_hWnd(ByVal Title As String) 'Sub①
    Num = 0
    ReDim hWnds(0)
    EnumWindows AddressOf EnumWindowsProc, 0
    If Num > 0 Then
        For i = 0 To Num - 1
            Call GetWinText(hWnds(i), Title)
            If InStr(1, Title, "google", vbTextCompare) > 0 Then
                IES_hWnd = hWnds(i)
                Exit For
            End If
        Next i
    End If
End Sub

Private Function EnumWindowsProc(ByVal hWndX As LongPtr, ByVal lParam As Long) As Long
    If IsWindowVisible(hWndX) Then
        Num = Num + 1
        ReDim Preserve hWnds(Num)
        hWnds(Num - 1) = hWndX
    End If
    EnumWindowsProc = 1
End Function

Private Sub GetWinText(ByVal hWndY As LongPtr, ByVal Title As String)
    Dim clsName As String * 256
    GetClassName hWndY, clsName, Len(clsName)
    If InStr(1, clsName, "Internet Explorer_Server", vbTextCompare) > 0 Then
        GetWindowText hWndY, Title, Len(Title)
    End If
End Sub

Private Sub Get_HTMLDocument(ByVal IES_hWnd As LongPtr) 'Sub②
    If IES_hWnd <> 0 Then
        Dim lMsg As LongPtr
        Dim lResult As LongPtr
        Dim IID_IHTMLDocument2 As GUID
        
        ' Register the message
        lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
        
        ' Get the IHTMLDocument2 interface
        SendMessageTimeout IES_hWnd, lMsg, 0, 0, SMTO_ABORTIFHUNG, 1000, lResult
        
        If lResult <> 0 Then
            Call ObjectFromLresult(lResult, IID_IHTMLDocument2, 0, objEdge)
        End If
    End If
End Sub
'-----------サブルーチン処理（おわり）----------
0
1
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
0
1