为何我的UserControl实现IobjectSafety接口后在IE中还是不能使用SubClass和WH_GETMESSAGE Hook

在WinForm中是正常的,在IE中SubClass 和Hook的代码都无效IObjectSafety的代码如下:Private Sub IObjectSafety_GetInterfaceSafetyOptions(ByVal riid As Long, pdwSupportedOptions As Long, pdwEnabledOptions As Long)   Dim IID     As String
   
   pdwSupportedOptions = INTERFACESAFE_FOR_UNTRUSTED_CALLER Or INTERFACESAFE_FOR_UNTRUSTED_DATA
   
   IID = GetIIDFromPTR(riid)
   
   Select Case IID
          Case IID_IDispatch
               pdwEnabledOptions = INTERFACESAFE_FOR_UNTRUSTED_DATA
               Exit Sub
          Case IID_IPersistStorage, IID_IPersistStream, IID_IPersistPropertyBag
               pdwEnabledOptions = pdwEnabledOptions Or INTERFACESAFE_FOR_UNTRUSTED_CALLER
               Exit Sub
          Case Else
               err.Raise E_NOINTERFACE
               Exit Sub
   End Select
   
End Sub
Private Sub IObjectSafety_SetInterfaceSafetyOptions(ByVal riid As Long, ByVal dwOptionsSetMask As Long, ByVal dwEnabledOptions As Long)
   
   Dim fSettings   As Long
   Dim IID         As String
   
   fSettings = (dwEnabledOptions And dwOptionsSetMask)
   IID = GetIIDFromPTR(riid)
   
   Select Case IID
          Case IID_IDispatch
               If (fSettings = INTERFACESAFE_FOR_UNTRUSTED_CALLER) Then
                  Exit Sub
               End If
                 
          Case IID_IPersistStorage, IID_IPersistStream, IID_IPersistPropertyBag
               If (fSettings = INTERFACESAFE_FOR_UNTRUSTED_DATA) Then
                  Exit Sub
               End If
                
          Case Else
               err.Raise E_NOINTERFACE
               Exit Sub
   End Select
                    
   err.Raise E_FAIL
                
End Sub'在Module中
Option ExplicitPublic Const IID_IDispatch = "{00020400-0000-0000-C000-000000000046}"
Public Const IID_IPersistStorage = "{0000010A-0000-0000-C000-000000000046}"
Public Const IID_IPersistStream = "{00000109-0000-0000-C000-000000000046}"
Public Const IID_IPersistPropertyBag = "{37D84F60-42CB-11CE-8135-00AA004BB851}"Public Const INTERFACESAFE_FOR_UNTRUSTED_CALLER = &H1
Public Const INTERFACESAFE_FOR_UNTRUSTED_DATA = &H2
Public Const E_NOINTERFACE = &H80004002
Public Const E_FAIL = &H80004005
Public Const MAX_GUIDLEN = 40Public Declare Function StringFromGUID2 Lib "ole32.dll" (rguid As Any, ByVal lpstrClsId As Long, ByVal cbMax As Integer) As LongPublic Type udtGUID
    Data1       As Long
    Data2       As Integer
    Data3       As Integer
    Data4(7)    As Byte
End TypePublic Function GetIIDFromPTR(ByVal riid As Long) As String
      
   Dim Rc          As Long                                         ' 函数返回代码
   Dim rClsId      As udtGUID                                      ' 指导结构
   Dim bIID()      As Byte                                         ' 界面标识符的字节数组
      
   If (riid <> 0) Then                                             ' 对界面标识符验证点
       CopyMemory rClsId, ByVal riid, Len(rClsId)                  ' 复制界面指导到结构
       bIID = String$(MAX_GUIDLEN, 0)                              ' 预分配字节数组
       Rc = StringFromGUID2(rClsId, VarPtr(bIID(0)), MAX_GUIDLEN)  ' 从指导结构获得 clsid
       Rc = InStr(1, bIID, vbNullChar) - 1                         ' 寻找尾随的空字符
       GetIIDFromPTR = Left$(UCase(bIID), Rc)                      ' 去掉额外的空，并且为了比较转换为大写字母
   End If
    
End Function

解决方案 »

  1.   

    是的,上面的代码是MSDN里Sample下面是处理Hook的代码:我只剪下一部份,因其它功能的须要我使用的是Hook:Private Sub Hook_HookMessage(ByVal bBefore As Boolean, ByRef bHandled As Boolean, ByRef lReturn As Long, ByVal HookType As eHookType, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long)
          If HookType = WH_GETMESSAGE Then
          If nCode = HC_ACTION And wParam = PM_REMOVE Then
          
             Dim uMsg       As Msg
             
             CopyMemory uMsg, ByVal lParam, Len(uMsg)
             
             '在控件内部滚动滚轮
              If uMsg.message = WM_MOUSEWHEEL Then
                '垂直滚动
                  If Sgn((uMsg.wParam And &HFFFF0000) \ &H10000) = 1 Then
                   '上
                      MsgBox "Up"
                Else
                   '下
                     MsgBox "Down"
                End If
             End If
             
           End If '//nCode = HC_ACTION And wParam = PM_REMOVE
       End If '//HookType = WH_GETMESSAGEEnd Sub
      

  2.   

    '下面是实现Hook的ClsHookOption Explicit' Paul Caton has done some amazing things combining ASM and VB.  Unfortunately, he has moved
    ' on from VB and left this code to me. His original code can be found at the links provided
    ' below. I am taking the initiative to learn from his thunks, update, rewrite, or otherwise
    ' improve those thunks. Therefore, some of this code will differ significantly from Paul's
    ' original work. As an ASM newbie, I welcome any suggestions/corrections for the ASM code itself.' If you are new to these thunking routines, here is the basic idea:
    ' 1. Make subclassing, hooking, callbacks IDE-safe. No crashes due to END or STOP
    ' 2. Be able to allow subclassing, hooking, callbacks to use a class, form,
    '       property page or usercontrol to call back to (just like an AddressOf pointer)
    ' 3. Allow that 'AddressOf' pointer to exist in any VB code object' Original work done by Paul Caton. Contributions made by Tai Chi Minh Ralph Eastwood and myself
    '   Caton> http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=64867&lngWId=1
    '   Caton> http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=51403&lngWId=1
    '   Eastwood> http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=66665&lngWId=1' This Post> http://www.planet-source-code.com/vb/scripts/ShowCode.asp?lngWId=1&txtCodeId=68737
    Public Event HookMessage(ByVal bBefore As Boolean, ByRef bHandled As Boolean, ByRef lReturn As Long, ByVal HookType As eHookType, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long)
    Public Event Timer(ByVal hWnd As Long, ByVal uMsg As Long, ByVal TimerID As Long, ByVal tickCount As Long)
    ' *******************************************************************************************************************
    '       THE ENTIRE CLASS OR PARTS HEREIN CAN ALSO BE ADDED TO A FORM, USERCONTROL (UC), or PROPERTY PAGE (PPG)
    '       ALLOWING SUBCLASSING, HOOKING, CALLBACKS CONTAINMENT WITHIN THE FORM/UC/PPG ITSELF.
    ' *******************************************************************************************************************
      
      ' Local variables/constants: must declare these regardless if using subclassing, hooking, callbacks
        Private z_scFunk            As Collection   'hWnd/thunk-address collection; initialized as needed
        Private z_hkFunk            As Collection   'hook/thunk-address collection; initialized as needed
        Private z_cbFunk            As Collection   'callback/thunk-address collection; initialized as needed
        Private Const IDX_INDEX     As Long = 2     'index of the subclassed hWnd OR hook type
        Private Const IDX_PREVPROC  As Long = 9     'Thunk data index of the original WndProc
        Private Const IDX_BTABLE    As Long = 11    'Thunk data index of the Before table for messages
        Private Const IDX_ATABLE    As Long = 12    'Thunk data index of the After table for messages
        Private Const IDX_CALLBACKORDINAL As Long = 36 ' Ubound(callback thunkdata)+1, index of the callback  ' Declarations:
        Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
        Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
        Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
        Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
        Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
        Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As Long) As Long
        Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
        Public Enum eThunkType
            SubclassThunk = 0
            HookThunk = 1
            CallbackThunk = 2
        End Enum
      

  3.   

      
        '-Selfsub specific declarations----------------------------------------------------------------------------
        Public Enum eMsgWhen                                                   'When to callback
          MSG_BEFORE = 1                                                        'Callback before the original WndProc
          MSG_AFTER = 2                                                         'Callback after the original WndProc
          MSG_BEFORE_AFTER = MSG_BEFORE Or MSG_AFTER                            'Callback before and after the original WndProc
        End Enum    ' see ssc_Subclass for complete listing of indexes and what they relate to
        Private Const IDX_PARM_USER As Long = 13    'Thunk data index of the User-defined callback parameter data index
        Private Const IDX_UNICODE   As Long = 107   'Must be UBound(subclass thunkdata)+1; index for unicode support
        Private Const MSG_ENTRIES   As Long = 32    'Number of msg table entries. Set to 1 if using ALL_MESSAGES for all subclassed windows
        Private Const ALL_MESSAGES  As Long = -1    'All messages will callback
        'Public Enum eAllMessages
        '    ALL_MESSAGES = -1                       'All messages will callback
        'End Enum
        Private Declare Function CallWindowProcA Lib "user32" (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 CallWindowProcW Lib "user32" (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 GetCurrentProcessId Lib "kernel32" () As Long
        Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
        Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
        Private Declare Function IsWindowUnicode Lib "user32.dll" (ByVal hWnd As Long) As Long
        Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare Function SetWindowLongW Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    '-------------------------------------------------------------------------------------------------'========================================================================================================
    ' TO USE IDE-SAFE HOOKING...
    '==============================
      
        '-SelfHook specific declarations----------------------------------------------------------------------------
        Private Declare Function SetWindowsHookExA Lib "user32" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hMod As Long, ByVal dwThreadId As Long) As Long
        Private Declare Function SetWindowsHookExW Lib "user32" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hMod As Long, ByVal dwThreadId As Long) As Long
        Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
        Private Declare Function CallNextHookEx Lib "user32.dll" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
        Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
        
        Public Enum eHookType  ' http://msdn2.microsoft.com/en-us/library/ms644990.aspx
          WH_MSGFILTER = -1
          WH_JOURNALRECORD = 0
          WH_JOURNALPLAYBACK = 1
          WH_KEYBOARD = 2
          WH_GETMESSAGE = 3
          WH_CALLWNDPROC = 4
          WH_CBT = 5
          WH_SYSMSGFILTER = 6
          WH_MOUSE = 7
          WH_DEBUG = 9
          WH_SHELL = 10
          WH_FOREGROUNDIDLE = 11
          WH_CALLWNDPROCRET = 12
          WH_KEYBOARD_LL = 13       ' NT/2000/XP+ only, Global hook only
          WH_MOUSE_LL = 14          ' NT/2000/XP+ only, Global hook only
        End Enum
    '-------------------------------------------------------------------------------------------------
                                                                          'Private Sub Class_Terminate()   ' sample terminate/unload event
      'ssc_Terminate      '(add this to Unload or Terminate event if you are subclassing)
      TerminateHooks  '(add this to Unload or Terminate event if you are hooking)
      TerminateCallbacks '(add this to Unload or Terminate event if you are using callbacks)
     End Sub
    '-SelfHook code------------------------------------------------------------------------------------
    '-The following routines are exclusively for the shk_SetHook routines----------------------------
    Public Function SetHook(ByVal HookType As eHookType, _
                        Optional ByVal bGlobal As Boolean = False, _
                        Optional ByVal When As eMsgWhen = MSG_BEFORE, _
                        Optional ByVal lParamUser As Long = 0, _
                        Optional ByVal nOrdinal As Long = 2, _
                        Optional ByVal oCallback As Object = Nothing, _
                        Optional ByVal bIdeSafety As Boolean = True, _
                        Optional ByRef bUnicode As Boolean = False) As Boolean 'Setting specified hook    '*************************************************************************************************
        '* HookType - One of the eHookType enumerators
        '* bGlobal - If False, then hook applies to app's thread else it applies Globally (only supported by WH_KEYBOARD_LL & WH_MOUSE_LL)
        '* When - either MSG_AFTER, MSG_BEFORE or MSG_BEFORE_AFTER
        '* lParamUser - Optional, user-defined callback parameter
        '* nOrdinal   - Optional, ordinal index of the callback procedure. 1 = last private method, 2 = second last private method, etc.
        '* oCallback  - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
        '* bIdeSafety - Optional, enable/disable IDE safety measures. There is no reason to set this to false
        '* bUnicode - Optional, if True, Unicode API calls should be made to the window vs ANSI calls
        '*            Parameter is byRef and its return value should be checked to know if ANSI to be used or not
        '*************************************************************************************************
        ' Hook procedure must be declared identical to the one near the end of this class (Sample at Ordinal #2)