VBA中替代Wait方法确保PutInClipboard执行完成的技术问询

你遇到的Win10剪贴板同步延迟问题我也碰过，硬等1秒确实有点浪费时间，这里有两个更高效的替代方案，能在保证验证准确的前提下，尽量减少不必要的等待：

方案1：循环轮询剪贴板内容（带超时） #

这种方式会主动检查剪贴板内容，一旦匹配预期就立刻继续执行，不用等满固定时长，还加了超时机制防止无限等待。

'Put the content of a variable into the clipboard
Dim strDesiredClipboardContent As String
strDesiredClipboardContent = "你的目标内容" '替换为你的变量值
Dim dataObject1 As DataObject
Set dataObject1 = New DataObject
dataObject1.SetText strDesiredClipboardContent
dataObject1.PutInClipboard

'循环检查剪贴板，带超时机制
Dim dataObject2 As MSForms.DataObject
Set dataObject2 = New MSForms.DataObject
Dim strActualClipboardContent As String
Dim startTime As Double
startTime = Timer '记录开始时间
Dim timeoutSeconds As Double
timeoutSeconds = 2 '可根据需求调整超时时间，比如2秒
Dim isSuccess As Boolean
isSuccess = False

Do While Timer < startTime + timeoutSeconds
    On Error Resume Next '临时忽略剪贴板读取错误（比如内容还未写入）
    dataObject2.GetFromClipboard
    strActualClipboardContent = dataObject2.GetText
    On Error GoTo 0 '恢复正常错误处理
    
    If strActualClipboardContent = strDesiredClipboardContent Then
        isSuccess = True
        Exit Do
    End If
    
    DoEvents '释放CPU资源，避免程序假死
Loop

'验证结果
If Not isSuccess Then
    MsgBox "Error: 剪贴板内容与预期不符，或等待超时"
End If

这个方案简单易实现，大部分场景下都够用——如果剪贴板很快同步完成，循环会立刻终止，不会浪费时间；如果遇到极端情况同步延迟，超时机制也能避免程序卡住。

方案2：利用Windows API监听剪贴板变化 #

如果追求极致精准，不想做任何无意义的轮询，可以用Windows API监听剪贴板的更新事件。当剪贴板内容真正完成更新时，我们再去验证，完全不需要主动等待。

注意：这个方案需要在类模块中实现（比如新建一个名为ClipboardListener的类模块），代码如下：

类模块 ClipboardListener 中的代码 #

'声明所需的Windows API
Private Declare PtrSafe Function SetClipboardViewer Lib "user32" (ByVal hWndNewViewer As LongPtr) As LongPtr
Private Declare PtrSafe Function ChangeClipboardChain Lib "user32" (ByVal hWndRemove As LongPtr, ByVal hWndNewNext As LongPtr) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) 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 SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr

Private Const WM_CHANGECBCHAIN = &H30D
Private Const WM_DRAWCLIPBOARD = &H308
Private Const GWL_WNDPROC = (-4)

Public Event ClipboardUpdated()
Private nextClipboardViewer As LongPtr
Private oldWndProc As LongPtr
Private hostHWnd As LongPtr

Public Sub StartListening(hWnd As LongPtr)
    hostHWnd = hWnd
    oldWndProc = SetWindowLongPtr(hostHWnd, GWL_WNDPROC, AddressOf WndProc)
    nextClipboardViewer = SetClipboardViewer(hostHWnd)
End Sub

Public Sub StopListening()
    ChangeClipboardChain hostHWnd, nextClipboardViewer
    SetWindowLongPtr hostHWnd, GWL_WNDPROC, oldWndProc
End Sub

Private Function WndProc(ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Select Case Msg
        Case WM_DRAWCLIPBOARD
            RaiseEvent ClipboardUpdated()
            SendMessage nextClipboardViewer, Msg, wParam, lParam
        Case WM_CHANGECBCHAIN
            If wParam = nextClipboardViewer Then
                nextClipboardViewer = lParam
            Else
                SendMessage nextClipboardViewer, Msg, wParam, lParam
            End If
    End Select
    WndProc = CallWindowProc(oldWndProc, hWnd, Msg, wParam, lParam)
End Function

标准模块中的调用代码 #

Dim WithEvents clipListener As ClipboardListener
Dim desiredClipboardContent As String
Dim verificationCompleted As Boolean

Sub CopyAndVerifyWithListener()
    desiredClipboardContent = "你的目标内容" '替换为你的变量值
    verificationCompleted = False
    
    Set clipListener = New ClipboardListener
    clipListener.StartListening Application.hWnd
    
    '复制内容到剪贴板
    Dim dataObject1 As DataObject
    Set dataObject1 = New DataObject
    dataObject1.SetText desiredClipboardContent
    dataObject1.PutInClipboard
    
    '等待验证完成或超时
    Dim startTime As Double
    startTime = Timer
    Do While Not verificationCompleted And Timer < startTime + 2
        DoEvents
    Loop
    
    clipListener.StopListening
    
    If Not verificationCompleted Then
        MsgBox "Error: 剪贴板内容未更新或等待超时"
    End If
End Sub

Private Sub clipListener_ClipboardUpdated()
    '剪贴板更新时触发验证
    Dim dataObject2 As MSForms.DataObject
    Set dataObject2 = New MSForms.DataObject
    On Error Resume Next
    dataObject2.GetFromClipboard
    Dim actualContent As String
    actualContent = dataObject2.GetText
    On Error GoTo 0
    
    If actualContent = desiredClipboardContent Then
        verificationCompleted = True
    End If
End Sub

这个方案完全基于事件驱动，只有剪贴板真的发生变化时才会执行验证，没有多余的等待，适合对效率要求很高的场景。

总结一下：如果只是想快速解决问题，方案1的循环轮询足够简单实用；如果追求最优性能，方案2的API监听是更专业的选择。

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