当我从代码模块中剪切文本时，如何阻止带有剪贴板监控的 Access 数据库崩溃？

Question

我有一个 Access 数据库，需要使用剪贴板监视来启用和禁用从剪贴板导入数据的按钮（基于是否适合导入）。当剪贴板监控打开时，它看起来基本上是稳定的，但值得注意的例外是，每当我从代码窗口“剪切”多行代码时，它就会在任何 VBA 代码执行之前立即崩溃。从代码窗口复制可以，从其他任何地方剪切也可以。 我正在按照指示在单独的模块中使用此处代码的修改版本（部分功能修改，部分将某些数据类型更改为 LongPtr，但崩溃发生在数据类型更改之前）。我尝试添加一个错误处理程序，但由于它在执行代码之前就崩溃了，所以它并没有真正产生任何区别。我的猜测是，从代码窗格中剪切文本会导致 AddressOf 语句中的地址无效，但如果这是问题所在，我不知道如何解决它。

https://www.mrexcel.com/board/threads/use-excel-as-a-clipboard.1216045/

修改版本：

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

Answer 1

#Const CLIP = False   

Sub Start()
#If CLIP Then
    Call CreateClipWindow
#End If
End Sub

通过这种方式，您可以关闭开发计算机上代码的启动。