VBA中复制内容后剪贴板未即时生效，如何强制更新？

问题核心 #

使用Range.Copy复制单元格内容后，宏运行期间外部软件无法读取剪贴板内容，仅在宏结束后内容才可用。这是因为Excel会在宏执行过程中独占剪贴板，不会立即将内容提交到系统剪贴板供其他进程访问，和等待时间无关。

解决方案 #

放弃依赖Range.Copy，改用Windows API直接将单元格内容写入系统剪贴板，确保外部软件能即时读取。

修改后的完整代码 #

' 基础操作API声明
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
Public Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10

' 剪贴板核心操作API
Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Public Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Public Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Public Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Public Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Public Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
Public Const CF_TEXT = 1
Public Const GMEM_MOVEABLE = &H2
Public Const GMEM_ZEROINIT = &H40

Sub RunAutomation()
    Dim targetRange As Range
    Dim cellText As String
    Dim row As Range
    
    ' 拼接目标区域的文本内容（按行分隔）
    Set targetRange = Worksheets("writeorder").Range("M" & firstrow & ":M" & lastrow)
    cellText = ""
    For Each row In targetRange.Rows
        cellText = cellText & row.Value & vbCrLf
    Next row
    
    ' 将文本写入剪贴板
    WriteTextToClipboard cellText
    
    ' 执行点击操作
    Sleep 500
    Call transactionclicksworkcomp
End Sub

' 自定义剪贴板写入函数
Sub WriteTextToClipboard(text As String)
    Dim hGlobalMemory As LongPtr
    Dim lpGlobalMemory As LongPtr
    Dim hClipMemory As LongPtr
    
    ' 打开剪贴板并清空
    If OpenClipboard(0&) = 0 Then Exit Sub
    EmptyClipboard
    
    ' 分配内存并写入文本
    hGlobalMemory = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(text) + 1)
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    lstrcpy lpGlobalMemory, text
    GlobalUnlock hGlobalMemory
    
    ' 将内容设置到剪贴板
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
    
    ' 关闭剪贴板
    CloseClipboard
End Sub

Sub transactionclicksworkcomp()
    SetCursorPos 517, 1059 'x and y position
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
    Sleep 500

    SetCursorPos 954, 33 'x and y position
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
    Sleep 500

    SetCursorPos 659, 1029 'x and y position
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
    Sleep 500

    SetCursorPos 588, 898 'x and y position
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
    Sleep 1200

    SetCursorPos 767, 895 'x and y position
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
    Sleep 1200

    SetCursorPos 705, 718 'x and y position
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
    Sleep 1200

    SetCursorPos 1668, 889 'x and y position
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
    Sleep 1200

    SetCursorPos 1852, 897 'x and y position
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
    Sleep 1200

    SetCursorPos 1852, 885 'x and y position
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
    Sleep 3000
End Sub

关键说明 #

1. 替换Range.Copy为WriteTextToClipboard函数，直接通过API将文本写入系统剪贴板，避免Excel独占剪贴板
2. 函数中先清空剪贴板，再分配内存写入内容，最后释放剪贴板控制权，确保外部软件能即时读取
3. 原有的鼠标点击逻辑完全保留，无需修改

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