Dim h as Long
Dim d as IHTMLDocument
    h = GetForegroundWindow
    Set d = IEDOMFromhWnd(h)

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

Private Const SMTO_ABORTIFHUNG = &H2

Private Declare Function ObjectFromLresult Lib "oleacc" ( _
   ByVal lResult As Long, _
   riid As UUID, _
   ByVal wParam As Long, _
   ppvObject As Any) As Long

Public Function IEDOMFromhWnd(ByVal hWnd As Long) As IHTMLDocument
  Dim IID_IHTMLDocument As UUID
  Dim hWndChild As Long
  Dim lRes As Long
  Dim lMsg As Long
  Dim hr As Long

  If hWnd <>  0  Then
    If Not IsIEServerWindow(hWnd) Then
      EnumChildWindows hWnd, AddressOf EnumChildProc, hWnd
    End If
    If hWnd <>  0  Then
      lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
      SendMessageTimeout hWnd, lMsg,  0 ,  0 , SMTO_ABORTIFHUNG,  1000 , lRes
      If lRes 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
        hr = ObjectFromLresult(lRes, IID_IHTMLDocument,  0 , IEDOMFromhWnd)
      End If
    End If
  End If
End Function

Private Declare Function ObjectFromLresult Lib "oleacc" ( _
   ByVal lResult As Long, _
   riid As UUID, _
   ByVal wParam As Long, _
   ppvObject As Any) As Long

Function EnumChildProc(ByVal hWnd As Long, lParam As Long) As Long
  If IsIEServerWindow(hWnd) Then
    lParam = hWnd
  Else
    EnumChildProc =  1 
  End If
End Function

Private Function IsIEServerWindow(ByVal hWnd As Long) As Boolean
  Dim lRes As Long
  Dim sClassName As String
  sClassName = String$( 100 ,  0 )
  lRes = GetClassName(hWnd, sClassName, Len(sClassName))
  sClassName = Left$(sClassName, lRes)
  IsIEServerWindow = StrComp(sClassName, "Internet Explorer_Server", vbTextCompare) =  0 
End Function

Dim WithEvents sws As ShellWindows

Private Sub Form_Load()
    Set sws = New ShellWindows
End Sub

Private Sub sws_WindowRegistered(ByVal lCookie As Long)
    'Срабатывает при открытии нового окна IE или Explorer'а
    'В коллекции ShellWindows находятся все их окна, в т.ч. открытые с помошью js.
End Sub