vba - Windows API WH_MOUSE hook 在模态模式下在 VBA 用户窗体上成功，但在无模式模式下失败

Question

(我的母语不是英语，我用的是google翻译，然后修改。如果有不对的地方，请原谅我糟糕的英语。)

我的目标是在MS Word中做一个带滚动条的Userform，希望能用鼠标滚轮滚动。

但 VBA 不提供 MouseScroll 事件处理程序。搜索了一下，知道可以用WinAPI Hook来实现。

我引用了“使用 Visual Basic 进行子类化和挂接(O'Reilly，2001)”中的示例。修改后，我的代码可以使用模态用户窗体成功执行。

但是当我打开Modeless模式下的Userform时，一旦执行了hook，整个Windows系统就会卡住，点击其他程序的windows没有反应，并且 CPU 使用率 > 80%。

我使用 Debug.Print 输出一些文本。当我查看 VBE 的即时窗口时，宏仍在执行，但它陷入了无限循环。

我的代码如下:(我使用 Win10 64 位和 Office 365 Word 64 位。64 位 API 声明根据 Microsoft's official website 上的文档。)

MouseHook 模块代码:

Option Explicit

Type POINTAPI
    X As Long
    Y As Long
End Type

Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hwnd As LongPtr
    wHitTestCode As Long
    dwExtraInfo As LongPtr
End Type

'This structure is just the extension of MOUSEHOOKSTRUCT
Type MOUSEHOOKSTRUCTEX
    structMouseHook As MOUSEHOOKSTRUCT
    mousedata As Long
End Type


Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
        ByVal idHook As Long, _
        ByVal lpfn As LongPtr, _
        ByVal hmod As LongPtr, _
        ByVal dwThreadId As Long) As LongPtr

Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
        ByVal hhk As LongPtr) As Long

Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
        ByVal hHook As LongPtr, _
        ByVal nCode As Long, _
        ByVal wParam As LongPtr, _
        lParam As Any) As LongPtr

Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long


Private Const WH_MOUSE As Long = 7
Private Const HC_ACTION As Long = 0

Public IsHooked As Boolean
Private mhook As LongPtr
Private i As Long


Public Sub SetMouseHook()
    
    If IsHooked Then
        MsgBox "Don't hook the MOUSE twice."
    Else
        'I perform thread-specific Hook
        mhook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseProc, 0, GetCurrentThreadId)
        IsHooked = True
    End If
End Sub

Public Sub RemoveMouseHook()
    Call UnhookWindowsHookEx(mhook)
    IsHooked = False
End Sub


Public Function MouseProc( _
    ByVal uCode As Long, _
    ByVal wParam As LongPtr, _
    lParam As MOUSEHOOKSTRUCTEX) As LongPtr

    If uCode = HC_ACTION Then

        Debug.Print i & "HC_ACTION" & lParam.mousedata: i = i + 1
        
        'To emphasize the keypoint, I omitted some irrelevant code.
        'lParam.mousedata gives you the direction of the mousewheel scrolling.
        '(by positive or negative)

    End If
    
    MouseProc = CallNextHookEx(mhook, uCode, wParam, lParam)

End Function

用户表单代码:(窗体有两个命令按钮，分别执行 Hook 和解钩功能。)

Option Explicit

Private Sub cmdHook_Click()
    Call SetMouseHook
End Sub

Private Sub cmdUnHook_Click()
    Call RemoveMouseHook
End Sub

    
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)        
    Call RemoveMouseHook
End Sub

如何解决这个问题？

如果无模式用户窗体不能使用 WH_MOUSE Hook ，是否有任何替代方法，例如 WH_MOUSE_LL Hook 或 VSTO？

谢谢大家

---

=====更新=====

在我的最终测试中，我发现“WH_MOUSE Hook”、“WH_MOUSE_LL Hook”和“Instance Subclassing”都可以在无模式 VBA 用户窗体中工作。但是您应该先关闭 VBE，然后从宏对话框 (ALT+F8) 中执行宏。 (我之前打开VBE执行宏。)

我的子类化代码如下:

子类化用户表单代码:

Option Explicit

'the Userform name is "frmSubclass"
'it contains 2 cmdButtons and 1 Frame with vertical scrollbar
'click the "SetSubclass Button" to SetSubclass
'click the "UnSubclass Button" to unSubclass

Private Sub cmdSetSubclass_Click()
    Call SetSubclass
End Sub

Private Sub cmdUnSubclass_Click()
    Call unSubclass
End Sub

Private Sub UserForm_Initialize()
    Me.Frame1.ScrollBars = fmScrollBarsVertical
    Me.Frame1.ScrollHeight = 1000
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call unSubclass
End Sub

子类化bas模块代码:

Option Explicit

'WinAPI function
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As LongPtr

Declare PtrSafe Function GetWindow Lib "user32" ( _
        ByVal hwnd As LongPtr, _
        ByVal wCmd As Long) As LongPtr


Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" ( _
        ByVal hwnd As LongPtr, _
        ByVal nIndex As Long, _
        ByVal dwNewLong As LongPtr) As LongPtr

Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
        ByVal lpPrevWndFunc As LongPtr, _
        ByVal hwnd As LongPtr, _
        ByVal Msg As Long, _
        ByVal wParam As LongPtr, _
        ByVal lParam As LongPtr) As LongPtr

'Windows constant
Private Const GW_CHILD As Long = 5
Private Const GWLP_WNDPROC As Long = -4
Private Const WM_MOUSEWHEEL As Long = &H20A

'module-level variables
Private m_OrigWndProc As LongPtr
Private m_hwnd As LongPtr


Public Function SetSubclass() As Boolean
    
    'I want to Subclassing the frame window inside the Main Userform
    'not the Main userform itself
    
    'get hwnd of Main Userform window which classname is "ThunderDFrame" in VBA
    m_hwnd = FindWindow("ThunderDFrame", vbNullString)
    Debug.Print IIf(m_hwnd <> 0, "Find Window: " & Hex$(m_hwnd), "Window not Find")

    'get hwnd of client window of Main Userform
    m_hwnd = GetWindow(m_hwnd, GW_CHILD)
    Debug.Print IIf(m_hwnd <> 0, "Find Window: " & Hex$(m_hwnd), "Window not Find")

    'get hwnd of Frame window
    m_hwnd = GetWindow(m_hwnd, GW_CHILD)
    Debug.Print IIf(m_hwnd <> 0, "Find Window: " & Hex$(m_hwnd), "Window not Find")
    
    'I use spy++ to watch all hwnd values, the 3 values of m_hwnd is correct
    
    
    'set Subclass and store the Original Window Procedure
    If m_OrigWndProc <> 0 Then
        Debug.Print "Already subclassed" 'Do not allow to subclass a 2nd time
    Else
        m_OrigWndProc = SetWindowLongPtr(m_hwnd, GWLP_WNDPROC, AddressOf SubclassWndProc)
        Debug.Print "Subclassing succeed."
    End If

End Function


Public Function unSubclass() As Boolean

    If m_OrigWndProc <> 0 Then
        SetWindowLongPtr m_hwnd, GWLP_WNDPROC, m_OrigWndProc
        m_OrigWndProc = 0
    End If

End Function


Public Function SubclassWndProc( _
    ByVal hwnd As LongPtr, _
    ByVal uMsg As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr) As LongPtr

    On Error Resume Next

    If uMsg = WM_MOUSEWHEEL Then
                
        'the Userform name is "frmSubclass"
        frmSubclass.Caption = " wParam = " & wParam
        
        'By observing the value of wParam, we can know
        '4287102976 represents scrolling down,7864320 represents scrolling up
        If wParam = 4287102976# Then
            frmSubclass.Frame1.ScrollTop = frmSubclass.Frame1.ScrollTop + 15
        ElseIf wParam = 7864320 Then
            frmSubclass.Frame1.ScrollTop = frmSubclass.Frame1.ScrollTop - 15
        End If

    End If

    'Pass message to the default window procedure
    SubclassWndProc = CallWindowProc(m_OrigWndProc, hwnd, uMsg, wParam, lParam)
End Function

起点bas模块代码:

Option Explicit

Sub testSubclass()
    frmSubclass.Show vbModeless 'the Userform name is "frmSubclass"
End Sub

Answer 1

你提到的那本书叫做“子类化和 Hook ”。您尝试了“ Hook ”，而实际上您的问题更适合“子类化”。

您应该在要处理“WM_MOUSEWHEEL”消息的地方子类化您的用户表单。查看“SetWindowLong”和“CallWindowProc”函数以实现此目标。