起動中のMicrosoft EdgeからタイトルとURLを取得するVBAマクロ(DOM編)

ホーム
Windows 10, Excel, Office関連, Word, Windows関連, PowerPoint, Microsoft Edge
起動中のMicrosoft EdgeからタイトルとURLを取得するVBAマクロ(DOM編)

2015.08.14

起動中のMicrosoft EdgeからタイトルとURLを取得するVBAマクロ(DOM編)

前回の記事で、UI Automationを使って起動中のMicrosoft EdgeからタイトルとURLを取得するVBAマクロを紹介しましたが、以前書いた記事「Microsoft Edgeを操作するVBAマクロ(DOM編)」でEdgeの中にあるInternet Explorer_ServerウィンドウからHTMLDocument(JScriptTypeInfoでしたが…)を取得できることが分かっているので、こちらを使った方が楽にEdgeで開いているページの情報を取得することができます。

2015/9/29 追記：
コードに一部不具合があったので修正しました。

※ 下記コードは64ビット版Officeでは動作しませんので、コードを書き換える必要があります。

'標準モジュール
Option Explicit

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

Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, lParam As Long) As Long
Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) 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 GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) 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 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 Const SMTO_ABORTIFHUNG = &H2

Private hEdge As Long

Public Sub ListEdgeTabInfo()
'起動中のEdgeのタブからタイトルとURLを取得(64ビット版Officeでは不可)
'http://www.mvps.org/emorcillo/en/code/vb6/iedom.shtml 参照
  hEdge = 0 '初期化
  EnumWindows AddressOf EnumWindowsProc, 0
  If hEdge = 0 Then Exit Sub
  EnumChildWindows hEdge, AddressOf EnumChildProc, 0
End Sub

Private Function EnumWindowsProc(ByVal hWnd As Long, lParam As Long) As Long
  Dim buf1 As String * 255
  Dim buf2 As String * 255
  Dim ClassName As String
  Dim WindowName As String
  Dim hTmp As Long
  
  hTmp = 0 '初期化
  If IsWindowVisible(hWnd) Then
    GetClassName hWnd, buf1, Len(buf1)
    ClassName = Left(buf1, InStr(buf1, vbNullChar) - 1)
    Select Case ClassName
      Case "ApplicationFrameWindow" '非最小化時
        hTmp = FindWindowEx(hWnd, 0, "Windows.UI.Core.CoreWindow", "Microsoft Edge")
        If hTmp <> 0 Then
          hEdge = hWnd
          EnumWindowsProc = False
          Exit Function
        End If
      Case "Windows.UI.Core.CoreWindow" '最小化時
        GetWindowText hWnd, buf2, Len(buf2)
        WindowName = Left(buf2, InStr(buf2, vbNullChar) - 1)
        If WindowName = "Microsoft Edge" Then
          hEdge = hWnd
          EnumWindowsProc = False
          Exit Function
        End If
    End Select
  End If
  EnumWindowsProc = True
End Function

Private Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
  Dim buf As String * 255
  Dim ClassName As String
  Dim d As Object
  
  GetClassName hWnd, buf, Len(buf)
  ClassName = Left(buf, InStr(buf, vbNullChar) - 1)
  If ClassName = "Internet Explorer_Server" Then
    Set d = GetHTMLDocumentFromWindow(hWnd)
    If Not d Is Nothing Then
      Debug.Print d.Title, d.Location.href
    End If
  End If
  EnumChildProc = True
End Function

Private Function GetHTMLDocumentFromWindow(ByVal hWnd As Long) As Object
  Dim msg As Long
  Dim res As Long
  Dim ret As Object
  Dim d As Object
  Dim IID_IHTMLDocument As UUID
  
  Set ret = Nothing '初期化
  msg = RegisterWindowMessage("WM_HTML_GETOBJECT")
  SendMessageTimeout hWnd, msg, 0, 0, SMTO_ABORTIFHUNG, 1000, res
  If res Then
    With IID_IHTMLDocument
      .Data1 = &H626FC520
      .Data2 = &HA41E
      .Data3 = &H11CF
      .Data4(0) = &HA7
      .Data4(1) = &H31
      .Data4(2) = &H0
      .Data4(3) = &HA0
      .Data4(4) = &HC9
      .Data4(5) = &H8
      .Data4(6) = &H26
      .Data4(7) = &H37
    End With
    If ObjectFromLresult(res, IID_IHTMLDocument, 0, d) = 0 Then Set ret = d
  End If
  Set GetHTMLDocumentFromWindow = ret
End Function

上記コードでやっていることは「Microsoft Edgeを操作するVBAマクロ(DOM編)」とほぼ同じで、Internet Explorer_Serverウィンドウを探して順番にDOM操作を行っているだけです。

ただ、Edgeが最小化されている場合はApplicationFrameWindowの子ウィンドウからInternet Explorer_Serverウィンドウを取得することができなかったため、最小化時の処理は別にしています。