LoginSignup
4
13

More than 1 year has passed since last update.

@ymd65536-ms(Kento Yamada)

【VBA】IEモードでHTMLDocument を取得したり操作したりするための関数を書いた

Last updated at Posted at 2022-02-07

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') で こうすることで
閉じるときに確認画面が表示されるウィンドウも警告なしで閉じることができる。

4
13
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
4
13