Option Explicit
 
Private mvar_hWnd As Long
Private mvar_bSubClass As Boolean
Private mvar_OldWindowProc As Long
 
Public Event MessageCatched( _
  ByVal hWnd As Long, _
  ByRef uMsg As Long, _
  ByRef wParam As Long, _
  ByRef lParam As Long, _
  ByRef bCancel As Boolean)
 
 
Private Declare Function SetWindowLong Lib "user32" _
  Alias "SetWindowLongA" ( _
  ByVal hWnd As Long, _
  ByVal nIndex As Long, _
  ByVal dwNewLong As Long) As Long
 
Private Declare Function CallWindowProc Lib "user32" _
  Alias "CallWindowProcA" ( _
  ByVal lpPrevWndFunc As Long, _
  ByVal hWnd As Long, _
  ByVal Msg As Long, _
  ByVal wParam As Long, _
  ByVal lParam As Long) As Long
 
Private Declare Function IsWindow Lib "user32" ( _
  ByVal hWnd As Long) As Long
 
 
Private Const GWL_WNDPROC = (-4)
 
Friend Function NewWindowProc( _
  ByVal hWnd As Long, _
  ByVal uMsg As Long, _
  ByVal wParam As Long, _
  ByVal lParam As Long) As Long
 
  Dim bCancel As Boolean
  bCancel = False
 
  NewWindowProc = 0
  If Not bCancel Then
    NewWindowProc = CallWindowProc(mvar_OldWindowProc, _
      hWnd, uMsg, wParam, lParam)
  End If
End Function
 
Public Function StartSubclass(ByVal hWnd As Long) As Boolean
  Dim lRet As Long
 
  If mvar_bSubClass Then
    StartSubclass = False
    Exit Function
  End If
 
  mvar_bSubClass = True
  mvar_hWnd = hWnd
 
 If IsWindow(hWnd) Then
   lRet = SetWindowLong(hWnd, GWL_WNDPROC, _
     AddressOf modWindowProc)
 
   If lRet <> 0 Then
     StartSubclass = True
     mvar_OldWindowProc = lRet
     lClassAdress = ObjPtr(Me)
   Else
     StartSubclass = False
   End If
  Else
    StartSubclass = False
  End If
End Function
 
Public Function StopSubClass() As Boolean
  Dim lRet As Long
 
  StopSubClass = True
  If mvar_bSubClass Then
    lRet = SetWindowLong(mvar_hWnd, GWL_WNDPROC, _
      mvar_OldWindowProc)
    If lRet <> 0 Then
      mvar_bSubClass = False
    Else
      StopSubClass = False
    End If
  End If
End Function
 
Private Sub Class_Initialize()
  mvar_bSubClass = False
  lClassAdress = ObjPtr(Me)
End Sub
 
Private Sub Class_Terminate()
  Dim bResult As Boolean
  bResult = StopSubClass
End Sub

Option Explicit
 
Public lClassAdress As Long
 
Private Declare Sub CopyMemory Lib "kernel32" _
  Alias "RtlMoveMemory" ( _
  Destination As Any, _
  Source As Any, _
  ByVal Length As Long)
 
Public Function modWindowProc( _
  ByVal hWnd As Long, _
  ByVal uMsg As Long, _
  ByVal wParam As Long, _
  ByVal lParam As Long) As Long
 
  Dim oSubClass As SubClassing
 
  CopyMemory oSubClass, lClassAdress, 4
 
  modWindowProc = oSubClass.NewWindowProc(hWnd, _
    uMsg, wParam, lParam)
  CopyMemory oSubClass, 0&, 4
End Function