Private WithEvents winShell As SHDocVw.ShellWindows
Private mCol As Collection
Dim bRefreshing As Boolean

Public Event IEWindowRegistered()
Public Event IEWindowRevoked()
Public Event IENavigationBegin(hwnd As Long, ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
Public Event IENavigationComplete(hwnd As Long, ByVal pDisp As Object, URL As Variant)
Public Event IEDocumentComplete(hwnd As Long, ByVal pDisp As Object, URL As Variant)
Public Event IEDownloadBegin(hwnd As Long)
Public Event IEDownloadComplete(hwnd As Long)
Public Event IEOnContextMenu(hwnd As Long)
Public Event IEMouseDown(hwnd As Long, Button As Long, Shift As Long, X As Single, Y As Single)
Public Event IEMouseUp(hwnd As Long, Button As Long, Shift As Long, X As Single, Y As Single)
Public Event IECommandStateChange(hwnd As Long, Button As CommandStateChangeConstants, Enable As Boolean)

Private Function Add(IEctl As SHDocVw.InternetExplorer) As IE_Class
Dim objNewMember As IE_Class
    Set objNewMember = New IE_Class
    Set objNewMember.IEctl = IEctl
    mCol.Add objNewMember ', h & objNewMember.IEHandle
    Set Add = objNewMember
    Set objNewMember = Nothing
End Function

Public Property Get IE(vntIndexKey As Variant) As IE_Class
  Do While bRefreshing
     DoEvents
  Loop
  Set IE = mCol(vntIndexKey)
End Property

Public Property Get Count() As Long
   Count = mCol.Count
End Property

Private Sub Remove(vntIndexKey As Variant)
   mCol.Remove vntIndexKey
End Sub

Public Property Get NewEnum() As IUnknown
   Set NewEnum = mCol.[_NewEnum]
End Property

Private Sub Class_Initialize()
  cIEWPtr = ObjPtr(Me)
  Refresh_Col
End Sub

Private Sub Class_Terminate()
   Set mCol = Nothing
   Set winShell = Nothing
End Sub

Private Sub winShell_WindowRegistered(ByVal lCookie As Long)
  Refresh_Col
  Do While bRefreshing
     DoEvents
  Loop
  RaiseEvent IEWindowRegistered
End Sub

Private Sub winShell_WindowRevoked(ByVal lCookie As Long)
  Refresh_Col
  Do While bRefreshing
     DoEvents
  Loop
  RaiseEvent IEWindowRevoked
End Sub

Public Sub Refresh_Col()
Dim SWs As New SHDocVw.ShellWindows
Dim var As SHDocVw.InternetExplorer
   bRefreshing = True
   Set mCol = Nothing
   Set mCol = New Collection
   For Each var In SWs
       Add var
   Next
   Set winShell = SWs
   Set SWs = Nothing
   Set var = Nothing
   bRefreshing = False
End Sub

Friend Function FireEvent(nEvent As IDEVENTS, hwnd As Long, ParamArray EventInfo())
   Select Case nEvent
          Case ID_BeforeNavigate
               RaiseEvent IENavigationBegin(hwnd, EventInfo(0), EventInfo(1), EventInfo(2), EventInfo(3), EventInfo(4), EventInfo(5), CBool(EventInfo(6)))
          Case ID_NavigationComplete
               RaiseEvent IENavigationComplete(hwnd, EventInfo(0), EventInfo(1))
          Case ID_DocumentComplete
               RaiseEvent IEDocumentComplete(hwnd, EventInfo(0), EventInfo(1))
          Case ID_DownloadBegin
               RaiseEvent IEDownloadBegin(hwnd)
          Case ID_DownloadComplete
               RaiseEvent IEDownloadComplete(hwnd)
          Case ID_ContextMenu
               RaiseEvent IEOnContextMenu(hwnd)
          Case ID_MouseDown
               RaiseEvent IEMouseDown(hwnd, CInt(EventInfo(0)), CInt(EventInfo(1)), CSng(EventInfo(2)), CSng(EventInfo(3)))
          Case ID_MouseUp
               RaiseEvent IEMouseUp(hwnd, CInt(EventInfo(0)), CInt(EventInfo(1)), CSng(EventInfo(2)), CSng(EventInfo(3)))
          Case ID_CommandStateChange
               RaiseEvent IECommandStateChange(hwnd, CLng(EventInfo(0)), CBool(EventInfo(1)))
   End Select
End Function

'Private Type POINTAPI
'   X As Long
'   Y As Long
'End Type
'
'Private Declare Function GetAsyncKeyState% Lib "user32" (ByVal vKey As Long)
'Private Declare Function GetCursorPos& Lib "user32" (lpPoint As POINTAPI)
'Private Declare Function ScreenToClient& Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI)
'Private Declare Function GetKeyState% Lib "user32" (ByVal nVirtKey As Long)

Private WithEvents IE As SHDocVw.InternetExplorer
Private WithEvents IEDoc As MSHTML.HTMLDocument
Private mvarIEHandle As Long 'local copy
'Private mvarEnableBack As Boolean 'local copy
'Private mvarEnableForward As Boolean 'local copy

Private bLDown As Boolean, bRDown As Boolean

Public Property Get EnableForward() As Boolean
   EnableForward = mvarEnableForward
End Property

Public Property Get EnableBack() As Boolean
   EnableBack = mvarEnableBack
End Property

Public Property Set IEctl(IncomeIE As SHDocVw.InternetExplorer)
   Set IE = IncomeIE
   mvarIEHandle = IncomeIE.hwnd
   On Error Resume Next
   Set IEDoc = IncomeIE.Document
   bCancel = True
   Err.Clear
   IE.GoForward
   If Err Then
      mvarEnableForward = False
      bCancel = False
   Else
      IE.ExecWB OLECMDID_STOPDOWNLOAD, OLECMDEXECOPT_DONTPROMPTUSER
   End If
   On Error GoTo 0
End Property

Public Property Get IEctl() As SHDocVw.InternetExplorer
   Set IEctl = IE
End Property

Public Property Get IEHandle() As Long
    IEHandle = mvarIEHandle
End Property

'Private Sub IE_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
'    'CallEvent ID_BeforeNavigate, mvarIEHandle, pDisp, URL, Flags, TargetFrameName, PostData, Headers, Cancel
'    If bCancel Then
'       Cancel = True
'       bCancel = False
'    End If
'End Sub

'Private Sub IE_CommandStateChange(ByVal Command As Long, ByVal Enable As Boolean)
'   Select Case Command
'     Case CSC_NAVIGATEBACK
'          mvarEnableBack = Enable
'     Case CSC_NAVIGATEFORWARD
'          mvarEnableForward = Enable
'   End Select
'   'CallEvent ID_CommandStateChange, mvarIEHandle, Command, Enable
'End Sub

'Private Sub IE_DocumentComplete(ByVal pDisp As Object, URL As Variant)
'  If pDisp Is IE Then
'     'callEvent ID_DocumentComplete, mvarIEHandle, pDisp, URL
'  End If
'End Sub
'
'Private Sub IE_DownloadBegin()
'  CallEvent ID_DownloadBegin, mvarIEHandle
'End Sub
'
'Private Sub IE_DownloadComplete()
'  CallEvent ID_DownloadComplete, mvarIEHandle
'End Sub
'
'Private Sub IE_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
'  CallEvent ID_NavigationComplete, mvarIEHandle, pDisp, URL
'End Sub

Private Sub Class_Terminate()
  On Error Resume Next
  Set IE = Nothing
End Sub

'Private Function IEDoc_oncontextmenu() As Boolean
'   CallEvent ID_ContextMenu, mvarIEHandle
'   IEDoc_oncontextmenu = Not bCancel
'   If bCancel = True Then bCancel = False
'End Function
'
'Private Sub IEDoc_onmousedown()
'   Dim pt As POINTAPI
'   Dim btn As Long, i As Long
'   GetCursorPos pt
'   ScreenToClient mvarIEHandle, pt
'   If GetAsyncKeyState(vbKeyLButton) < 0 Then
'      btn = 1: bLDown = True
'   Else
'      btn = 2: bRDown = True
'   End If
'   If GetAsyncKeyState(vbKeyShift) Then i = 1
'   If GetAsyncKeyState(vbKeyControl) Then i = 2
'   If GetAsyncKeyState(vbKeyMenu) Then i = 4
'   CallEvent ID_MouseDown, mvarIEHandle, btn, i, CSng(pt.X), CSng(pt.Y)
'End Sub
'
'Private Sub IEDoc_onmouseup()
'   Dim pt As POINTAPI
'   Dim btn As Long, i As Long
'   GetCursorPos pt
'   ScreenToClient mvarIEHandle, pt
'   If bLDown Then
'      btn = 1: bLDown = False
'   Else
'      btn = 2: bRDown = False
'   End If
'   If GetAsyncKeyState(vbKeyShift) Then i = 1
'   If GetAsyncKeyState(vbKeyControl) Then i = 2
'   If GetAsyncKeyState(vbKeyMenu) Then i = 4
'   CallEvent ID_MouseUp, mvarIEHandle, btn, i, CSng(pt.X), CSng(pt.Y)
'End Sub