Access VBA MouseHook Wrapper随机崩溃问题排查及修复咨询

开发者阿泽

2026-7-19

Access VBA鼠标钩子随机崩溃问题排查与修复

核心需求

实现主Access窗口与弹出式窗体同步移动/调整大小：当弹出式窗体被移动/调整大小时，主窗口同步执行对应操作。因隐藏主窗口会导致弹出菜单和非弹窗窗体无法显示，采用MouseHook Wrapper方案，但存在随机崩溃问题。

崩溃原因排查

全局变量竞态冲突
公共模块中的isMouseDown、isMouseMoved是全局变量，鼠标钩子回调为高频触发逻辑，多线程重入时会导致变量值被意外覆盖，引发逻辑混乱甚至崩溃。
钩子回调与Access UI线程冲突
WH_MOUSE_LL属于全局低级别钩子，回调函数运行在Access UI线程中，若回调内执行耗时操作或直接操作Access窗体对象，会阻塞UI线程，触发Access稳定性问题。
窗体注册/注销逻辑错误
clsMouseHook的UnregisterForm方法中，判断条件colHooks(i).Parent Is FRM不成立——clsIHook的Parent属性从未赋值，导致已关闭的窗体对象无法从集合中移除，引发内存泄漏和无效对象访问。
未定义的API依赖类型
目标窗体中使用了RECT类型但未声明，运行时会触发隐式类型错误，导致随机崩溃。
钩子释放不彻底
错误处理中仅调用UnhookWindowsHookEx，但未清理全局变量（如cHook、hHook），残留的无效钩子句柄会导致后续操作出错。
日志对象的并发访问风险
全局日志对象lHook在钩子回调和类方法中被交叉访问，高频触发时可能引发文件访问冲突，导致崩溃。

修复方案与代码调整

1. 替换全局变量，使用类级状态管理

将公共模块中的全局状态变量移至clsMouseHook类内部，避免竞态冲突。

2. 优化钩子回调逻辑

简化回调内操作，仅做事件转发，将窗体操作逻辑移至事件处理函数中；确保CallNextHookEx始终正确调用，避免阻塞钩子链。

3. 修复窗体注册/注销逻辑

在RegisterForm时为clsIHook的Parent属性赋值，确保UnregisterForm能正确找到并移除目标窗体对象。

4. 补充缺失的类型声明

添加RECT和POINTAPI的类型声明，避免隐式类型错误。

5. 完善钩子释放与资源清理

在窗体关闭、类销毁时彻底清理钩子句柄、集合对象和全局变量，避免残留无效资源。

6. 简化日志逻辑（可选）

若日志不是必需功能，可暂时移除或改用更安全的日志方式，避免文件访问冲突。

修改后的完整代码

公共模块（mdl_MouseHook）

Option Compare Database
Option Explicit

' 补充缺失的类型声明
Public Type POINTAPI
    X As Long
    Y As Long
End Type

Public Type RECT
    X1 As Long
    Y1 As Long
    X2 As Long
    Y2 As Long
End Type

Public 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
Public Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hhk As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Public Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
Public Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Public Declare PtrSafe Function GetWindowTextA Lib "user32" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare PtrSafe Function GetWindowTextLengthA Lib "user32" (ByVal hwnd As LongPtr) As Long
Public Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long

Public Const WH_MOUSE_LL = 14
Public Const HC_ACTION = 0
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_MOUSEWHEEL = &H20A
Public Const WM_LBUTTONUP = &H202
Public Const WM_RBUTTONUP = &H205

Public cHook As clsMouseHook
Public hHook As LongPtr

' 钩子回调函数：仅做事件转发，避免复杂逻辑
Public Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, lParam As MSLLHOOKSTRUCT) As LongPtr
    On Error Resume Next ' 简化错误处理，避免阻塞钩子链
    
    If nCode = HC_ACTION And Not cHook Is Nothing And cHook.HookedForms.Count > 0 Then
        Dim currentHwnd As LongPtr
        currentHwnd = GetForegroundWindow
        
        Select Case wParam
            Case WM_LBUTTONDOWN
                cHook.OnMouseDown currentHwnd, 1, lParam.PT.X, lParam.PT.Y
            Case WM_LBUTTONUP
                cHook.OnMouseUp currentHwnd, 1, lParam.PT.X, lParam.PT.Y
            Case WM_RBUTTONDOWN
                cHook.OnMouseDown currentHwnd, 2, lParam.PT.X, lParam.PT.Y
            Case WM_RBUTTONUP
                cHook.OnMouseUp currentHwnd, 2, lParam.PT.X, lParam.PT.Y
            Case WM_MOUSEMOVE
                cHook.OnMouseMove currentHwnd, lParam.PT.X, lParam.PT.Y
        End Select
    End If
    
    ' 必须始终调用CallNextHookEx，否则会导致系统钩子链异常
    LowLevelMouseProc = CallNextHookEx(hHook, nCode, wParam, lParam)
End Function

窗体子类（clsIHook）

Option Compare Database
Option Explicit

Private FRM As Access.Form
Public Parent As clsMouseHook ' 用于关联父类
Private frmHwnd As LongPtr

Public Property Get HookedForm() As Access.Form
    Set HookedForm = FRM
End Property

Public Property Set HookedForm(accForm As Access.Form)
    Set FRM = accForm
    frmHwnd = FRM.hwnd
End Property

Public Property Get Hwnd() As LongPtr
    Hwnd = frmHwnd
End Property

包装类（clsMouseHook）

Option Compare Database
Option Explicit

Private colHooks As Collection
Private blnIsHooked As Boolean
' 将原全局状态变量移至类内部
Private isMouseDown As Boolean
Private isMouseMoved As Boolean
Private lastMousePos As POINTAPI

Public Event FormMouseDown(hwnd As LongPtr, Button As Long, X As Long, Y As Long)
Public Event FormMouseUp(hwnd As LongPtr, Button As Long, X As Long, Y As Long, WasDragged As Boolean)
Public Event FormMouseDrag(hwnd As LongPtr, X As Long, Y As Long)

Private Sub Class_Initialize()
    Set colHooks = New Collection
End Sub

Public Property Get HookedForms() As Collection
    Set HookedForms = colHooks
End Property

Public Property Get IsHooked() As Boolean
    IsHooked = blnIsHooked
End Property

Public Sub RegisterForm(FRM As Access.Form)
    Dim iHook As New clsIHook
    Set iHook.HookedForm = FRM
    Set iHook.Parent = Me ' 赋值Parent属性，用于注销时查找
    colHooks.Add iHook
End Sub

Public Sub UnregisterForm(FRM As Access.Form)
    Dim i As Integer
    For i = colHooks.Count To 1 Step -1 ' 反向遍历避免索引混乱
        If colHooks(i).HookedForm Is FRM Then
            colHooks.Remove i
            Exit For
        End If
    Next
End Sub

Public Sub Hook()
    On Error GoTo Eroare
    hHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, 0, 0)
    If hHook = 0 Then
        Err.Raise 5, , "创建钩子失败"
    Else
        blnIsHooked = True
    End If
    Exit Sub
Eroare:
    MsgBox Err.Description, vbCritical
End Sub

Public Sub Unhook()
    On Error Resume Next
    If hHook <> 0 Then
        UnhookWindowsHookEx hHook
        hHook = 0
    End If
    blnIsHooked = False
    Set colHooks = Nothing
End Sub

' 内部事件处理，管理状态
Public Sub OnMouseDown(hwnd As LongPtr, Button As Long, X As Long, Y As Long)
    isMouseDown = True
    isMouseMoved = False
    lastMousePos.X = X
    lastMousePos.Y = Y
    RaiseEvent FormMouseDown(hwnd, Button, X, Y)
End Sub

Public Sub OnMouseUp(hwnd As LongPtr, Button As Long, X As Long, Y As Long)
    Dim wasDragged As Boolean
    wasDragged = isMouseMoved
    RaiseEvent FormMouseUp(hwnd, Button, X, Y, wasDragged)
    isMouseDown = False
    isMouseMoved = False
End Sub

Public Sub OnMouseMove(hwnd As LongPtr, X As Long, Y As Long)
    If isMouseDown Then
        If Not isMouseMoved Then
            isMouseMoved = True
        End If
        ' 计算偏移量或直接传递当前坐标
        RaiseEvent FormMouseDrag(hwnd, X, Y)
    End If
End Sub

目标窗体调用代码

Option Compare Database
Option Explicit

Private WithEvents frmHook As clsMouseHook
Private TitleBarWasPressed As Boolean
Private FormIsResized As Boolean
Private originalPos As RECT

Private Sub Form_Close()
    If Not frmHook Is Nothing Then
        frmHook.UnregisterForm Me
        frmHook.Unhook
        Set frmHook = Nothing
    End If
    Set cHook = Nothing
End Sub

Private Sub Form_Load()
    Set cHook = New clsMouseHook
    Set frmHook = cHook
    frmHook.RegisterForm Me
    frmHook.Hook
End Sub

Private Sub frmHook_FormMouseDown(hwnd As LongPtr, Button As Long, X As Long, Y As Long)
    Dim rc As RECT
    GetWindowRect Me.hwnd, rc
    originalPos = rc ' 记录初始位置用于计算偏移
    
    If hwnd = Me.hwnd Then
        ' 判断是否点击标题栏（标题栏高度取30px）
        If Y >= rc.Y1 And Y <= rc.Y1 + 30 Then
            TitleBarWasPressed = True
        ' 判断是否点击右侧边缘（调整宽度）
        ElseIf X >= rc.X2 - 10 And X <= rc.X2 Then
            FormIsResized = True
        End If
    End If
End Sub

Private Sub frmHook_FormMouseDrag(hwnd As LongPtr, X As Long, Y As Long)
    Dim rc As RECT
    Dim mainWnd As LongPtr
    mainWnd = Application.hWndAccessApp ' 获取主Access窗口句柄
    
    If TitleBarWasPressed Then
        ' 计算偏移量
        Dim offsetX As Long, offsetY As Long
        offsetX = X - originalPos.X1
        offsetY = Y - originalPos.Y1
        
        ' 移动主窗口
        SetWindowPos mainWnd, 0, originalPos.X1 + offsetX, originalPos.Y1 + offsetY, 0, 0, &H1 Or &H2
        ' 移动当前窗体（可选，若需要同步保持相对位置）
        SetWindowPos Me.hwnd, 0, originalPos.X1 + offsetX, originalPos.Y1 + offsetY, 0, 0, &H1 Or &H2
    ElseIf FormIsResized Then
        ' 计算宽度变化
        Dim newWidth As Long
        newWidth = X - originalPos.X1
        
        ' 调整主窗口宽度
        SetWindowPos mainWnd, 0, 0, 0, newWidth, originalPos.Y2 - originalPos.Y1, &H4 Or &H2
        ' 调整当前窗体宽度
        SetWindowPos Me.hwnd, 0, 0, 0, newWidth, originalPos.Y2 - originalPos.Y1, &H4 Or &H2
    End If
End Sub

Private Sub frmHook_FormMouseUp(hwnd As LongPtr, Button As Long, X As Long, Y As Long, WasDragged As Boolean)
    TitleBarWasPressed = False
    FormIsResized = False
End Sub

' 补充SetWindowPos声明
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

内容的提问来源于stack exchange，提问作者Adelina Andreea trandafir

Access VBA MouseHook Wrapper随机崩溃问题排查及修复咨询

核心需求 #

崩溃原因排查 #

修复方案与代码调整 #

1. 替换全局变量，使用类级状态管理 #

2. 优化钩子回调逻辑 #

3. 修复窗体注册/注销逻辑 #

4. 补充缺失的类型声明 #

5. 完善钩子释放与资源清理 #

6. 简化日志逻辑（可选） #

修改后的完整代码 #

公共模块（mdl_MouseHook） #

窗体子类（clsIHook） #

包装类（clsMouseHook） #

目标窗体调用代码 #