如何解决Access数据库剪贴板监控剪切代码模块时崩溃的问题

AI 小北

2026-6-25

问题分析与修复方案

问题概述

在Access数据库中实现剪贴板监控功能，用于根据剪贴板内容判断是否启用导入数据按钮。整体运行稳定，但存在致命问题：从VBA代码窗口剪切多行代码时，数据库直接崩溃，无任何VBA代码执行；而从代码窗口复制内容、或在其他位置剪切内容时完全正常。

代码基于剪贴板监控示例修改而来（调整部分功能、适配LongPtr类型，崩溃问题在修改类型前已存在），已放在独立模块。添加错误处理无效，因为崩溃发生在VBA代码执行之前。推测是代码窗格剪切操作导致AddressOf指向的回调函数地址失效，但不知如何解决。

修改后的原始代码如下：

Option Explicit

Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private 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
Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardSequenceNumber Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function AddClipboardFormatListener Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function RemoveClipboardFormatListener Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function lstrlenW Lib "kernel32.dll" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function lstrcpyW Lib "kernel32.dll" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As Long
Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr


Sub Start()
    Call CreateClipWindow
End Sub

Sub Finish()
    Call CleanUp
End Sub


'_______________________________________ PRIVATE ROUTINES __________________________________________________

Private Sub CreateClipWindow()
    Dim lHiddenWnd As LongPtr
    
    If GetProp(Application.hwndAccessApp, "HiddenWnd") = 0 Then
        lHiddenWnd = CreateWindowEx(0, "Static", vbNullString, 0, 0, 0, 0, 0, 0, 0, 0, 0)
        Call SetProp(Application.hwndAccessApp, "HiddenWnd", lHiddenWnd)
        Call AddClipboardFormatListener(lHiddenWnd)
        Call SubClassClipBoardWatcherWindow(lHiddenWnd)
    End If
End Sub

Private Sub CleanUp()
    Call RemoveClipboardFormatListener(GetProp(Application.hwndAccessApp, "HiddenWnd"))
    Call SubClassClipBoardWatcherWindow(GetProp(Application.hwndAccessApp, "HiddenWnd"), False)
    Call DestroyWindow(GetProp(Application.hwndAccessApp, "HiddenWnd"))
    Call RemoveProp(Application.hwndAccessApp, "HiddenWnd")
End Sub
  
Private Sub SubClassClipBoardWatcherWindow(ByVal hwnd As LongPtr, Optional ByVal bSubclass As Boolean = True)

    Const GWLP_WNDPROC = (-4)
    If bSubclass Then
        If GetProp(Application.hwnd, "PrevProcAddr") = 0 Then
            Call SetProp(Application.hwndAccessApp, "PrevProcAddr", _
                SetWindowLong(hwnd, GWLP_WNDPROC, AddressOf ClipBoardWindowCallback))
        End If
    Else
        If GetProp(Application.hwndAccessApp, "PrevProcAddr") Then
            Call SetWindowLong(hwnd, GWLP_WNDPROC, GetProp(Application.hwndAccessApp, "PrevProcAddr"))
            Call RemoveProp(Application.hwndAccessApp, "PrevProcAddr")
        End If
    End If
End Sub

Private Function ClipBoardWindowCallback( _
        ByVal hwnd As LongPtr, _
        ByVal uMsg As Long, _
        ByVal wParam As LongPtr, _
        ByVal lParam As LongPtr _
    ) As LongPtr


    Const WM_CLIPBOARDUPDATE = &H31D
    Static lPrevSerial As Long
  
    Call SubClassClipBoardWatcherWindow(hwnd, False)
    If uMsg = WM_CLIPBOARDUPDATE Then
        If lPrevSerial <> GetClipboardSequenceNumber Then
            
           'DO STUFF HERE

            lPrevSerial = GetClipboardSequenceNumber
        End If
    End If
    Call SubClassClipBoardWatcherWindow(hwnd, True)
    ClipBoardWindowCallback = CallWindowProc(GetProp(Application.hwndAccessApp, "PrevProcAddr"), hwnd, uMsg, wParam, lParam)
End Function

Private Sub Auto_Close()
    Call CleanUp
End Sub

崩溃原因分析

核心问题出在ClipBoardWindowCallback函数内的反复取消/重新子类化操作：

Call SubClassClipBoardWatcherWindow(hwnd, False)
' ... 处理消息 ...
Call SubClassClipBoardWatcherWindow(hwnd, True)

每次窗口收到消息时都取消子类化，处理完再重新子类化，会严重破坏窗口过程的指针链。当从代码窗口剪切多行代码时，系统会连续发送多条剪贴板更新消息，此时指针链被反复修改，导致SetWindowLong/CallWindowProc调用时使用无效指针，直接触发Access崩溃。

另外，原代码中SubClassClipBoardWatcherWindow函数混用Application.hwnd和Application.hwndAccessApp，也可能导致窗口属性存储/读取异常。

修复方案

关键修改点

移除回调函数内的子类化操作，子类化仅在窗口创建时执行一次，清理时恢复一次
统一使用Application.hwndAccessApp存储窗口属性，避免混用
给剪贴板操作添加安全错误处理，防止剪贴板被占用时引发异常
优化序列号判断逻辑，确保只处理有效剪贴板更新

修复后的完整代码

Option Explicit

Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private 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
Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardSequenceNumber Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function AddClipboardFormatListener Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function RemoveClipboardFormatListener Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function lstrlenW Lib "kernel32.dll" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function lstrcpyW Lib "kernel32.dll" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As Long
Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr

' 剪贴板格式常量
Private Const CF_UNICODETEXT As Long = 13

Sub Start()
    Call CreateClipWindow
End Sub

Sub Finish()
    Call CleanUp
End Sub

'_______________________________________ PRIVATE ROUTINES __________________________________________________

Private Sub CreateClipWindow()
    Dim lHiddenWnd As LongPtr
    
    If GetProp(Application.hwndAccessApp, "HiddenWnd") = 0 Then
        lHiddenWnd = CreateWindowEx(0, "Static", vbNullString, 0, 0, 0, 0, 0, 0, 0, 0, 0)
        Call SetProp(Application.hwndAccessApp, "HiddenWnd", lHiddenWnd)
        Call AddClipboardFormatListener(lHiddenWnd)
        Call SubClassClipBoardWatcherWindow(lHiddenWnd)
    End If
End Sub

Private Sub CleanUp()
    Dim lHiddenWnd As LongPtr
    lHiddenWnd = GetProp(Application.hwndAccessApp, "HiddenWnd")
    
    If lHiddenWnd <> 0 Then
        Call RemoveClipboardFormatListener(lHiddenWnd)
        Call SubClassClipBoardWatcherWindow(lHiddenWnd, False)
        Call DestroyWindow(lHiddenWnd)
        Call RemoveProp(Application.hwndAccessApp, "HiddenWnd")
    End If
End Sub
  
Private Sub SubClassClipBoardWatcherWindow(ByVal hwnd As LongPtr, Optional ByVal bSubclass As Boolean = True)
    Const GWLP_WNDPROC = (-4)
    Dim lPrevProc As LongPtr
    
    If bSubclass Then
        lPrevProc = GetProp(Application.hwndAccessApp, "PrevProcAddr")
        If lPrevProc = 0 Then
            lPrevProc = SetWindowLong(hwnd, GWLP_WNDPROC, AddressOf ClipBoardWindowCallback)
            Call SetProp(Application.hwndAccessApp, "PrevProcAddr", lPrevProc)
        End If
    Else
        lPrevProc = GetProp(Application.hwndAccessApp, "PrevProcAddr")
        If lPrevProc <> 0 Then
            Call SetWindowLong(hwnd, GWLP_WNDPROC, lPrevProc)
            Call RemoveProp(Application.hwndAccessApp, "PrevProcAddr")
        End If
    End If
End Sub

Private Function ClipBoardWindowCallback( _
        ByVal hwnd As LongPtr, _
        ByVal uMsg As Long, _
        ByVal wParam As LongPtr, _
        ByVal lParam As LongPtr _
    ) As LongPtr

    Const WM_CLIPBOARDUPDATE = &H31D
    Static lPrevSerial As Long
    Dim lCurrentSerial As Long
    
    ' 先调用原窗口过程，确保系统消息正常处理
    ClipBoardWindowCallback = CallWindowProc(GetProp(Application.hwndAccessApp, "PrevProcAddr"), hwnd, uMsg, wParam, lParam)
    
    If uMsg = WM_CLIPBOARDUPDATE Then
        lCurrentSerial = GetClipboardSequenceNumber
        If lCurrentSerial <> lPrevSerial Then
            ' 处理剪贴板内容
            Call HandleClipboardContent
            lPrevSerial = lCurrentSerial
        End If
    End If
End Function

Private Sub HandleClipboardContent()
    Dim hClipData As LongPtr
    Dim pClipText As LongPtr
    Dim sClipText As String
    
    On Error GoTo Cleanup
    
    ' 检查剪贴板是否有文本格式
    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
        If OpenClipboard(0) Then
            hClipData = GetClipboardData(CF_UNICODETEXT)
            If hClipData <> 0 Then
                pClipText = GlobalLock(hClipData)
                If pClipText <> 0 Then
                    ' 读取Unicode文本
                    sClipText = String(lstrlenW(pClipText), vbNullChar)
                    Call lstrcpyW(StrPtr(sClipText), pClipText)
                    Call GlobalUnlock(hClipData)
                    
                    ' --------------------------
                    ' 这里编写你的判断逻辑，比如检查文本是否适合导入
                    ' 示例：Forms!MainForm.btnImport.Enabled = IsValidImportContent(sClipText)
                    ' --------------------------
                End If
            End If
            Call CloseClipboard
        End If
    End If
    
    Exit Sub
    
Cleanup:
    If OpenClipboard(0) Then Call CloseClipboard
    ' 可以添加错误日志逻辑
End Sub

Private Sub Auto_Close()
    Call CleanUp
End Sub

说明

移除了回调函数内的子类化操作，确保窗口过程指针稳定
把剪贴板内容处理逻辑分离到HandleClipboardContent函数，添加了完整的错误处理和剪贴板资源清理
调整了回调函数的执行顺序，先调用原窗口过程再处理自定义逻辑，避免阻塞系统消息
统一使用Application.hwndAccessApp存储属性，避免指针混乱

内容的提问来源于stack exchange，提问作者ecc450

如何解决Access数据库剪贴板监控剪切代码模块时崩溃的问题

问题概述 #

崩溃原因分析 #

修复方案 #

关键修改点 #

修复后的完整代码 #

说明 #

问题概述

崩溃原因分析

修复方案

关键修改点

修复后的完整代码

说明