Excel VBA导出数据至SQL时触发GetFromClipboard OpenClipboard Failed错误

现有一用于Excel到SQL数据传输的VBA宏，核心运行逻辑为：先将待传输数据导出为文本文件，再通过BCP读取该文本文件完成SQL上传，该导出方式生成的文本文件可完整保留特殊字符，满足BCP上传要求。
该宏此前运行稳定，近期运行时弹出GetFromClipboard OpenClipboard Failed错误，报错触发于剪贴板数据读取环节，对应原实现代码如下：

Public Sub ExportSheetToSQL(Tabname As String, Filename As String, Tablename As String, firstRow As String)

'define variables
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String

Dim CurrentWorkbook As String
Dim CurrentFormat As Long
Dim extnsion  As String

Application.DecimalSeparator = "."
Application.UseSystemSeparators = False

'get name of the workbook
CurrentWorkbook = ThisWorkbook.FullName
CurrentWorkbookName = ThisWorkbook.Name
CurrentFormat = ThisWorkbook.FileFormat

' Store current details for the workbook
SaveToDirectory = GetTempDirectory & "\"
extnsion = SaveToDirectory & Filename & ".txt"

'copy the workbook
'it is necessary to save it as an CVS file
Set CVSWorkbook = Workbooks.Add
With CVSWorkbook
    .Title = "CVS"
    .Subject = "CVS"
    .SaveAs Filename:=SaveToDirectory & "XLS" & Filename & ".xls"
End With

Workbooks(CurrentWorkbookName).Activate
Worksheets(Tabname).Select
Worksheets(Tabname).Copy Before:=CVSWorkbook.Sheets(1)
'clear formats
'it is necessary to get rid of the USD format
'CVSWorkbook.Worksheets(Tabname).Range("A:XZ").ClearFormats

Dim lastRowIndex As Long
lastRowIndex = 0
lastRowIndex = Worksheets(Tabname).Range("A200000").End(xlUp).Row

Application.CutCopyMode = False
Sheet2.UsedRange.Copy
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .GetFromClipboard
    CreateObject("scripting.filesystemobject").createtextfile(extnsion, True).Write .gettext
End With
Application.CutCopyMode = False

TargetWorkbook = CVSWorkbook.FullName
' MsgBox TargetWorkbook

User = 'get active user here
CVSWorkbook.Close savechanges:=True
   
'BCP UPLOAD CODE

End Sub

该错误本质是调用系统剪贴板接口时访问失败，常见诱因有以下几类：

• 剪贴板被第三方进程锁定：截图工具、输入法、Office剪贴板面板、杀毒软件、云同步类软件都可能临时锁定剪贴板，此时其他程序调用剪贴板读取接口会直接返回失败。
• 操作时序不匹配：代码执行Range.Copy后立刻发起剪贴板读取，没有给Excel留出完成数据写入剪贴板、释放占用的缓冲时间，当导出数据量较大时，该问题触发概率会显著升高。
• COM对象初始化异常：代码通过CLSID晚绑定创建剪贴板操作对象（MSForms.DataObject），在Office版本更新、系统权限策略调整后，可能出现对象未完成初始化就调用方法的情况，无法正常对接系统剪贴板。
• 复制范围异常：代码中硬编码复制Sheet2.UsedRange，如果Sheet2存在单元格格式损坏、已用范围异常膨胀的问题，会导致复制操作实际未完成，剪贴板内无有效数据，读取时直接报错。

优先选择无剪贴板依赖的实现方式，从根源规避剪贴板相关故障；如果需要保留原有剪贴板导出的格式兼容性，可增加重试与等待逻辑提升稳定性。

• 方案1：移除剪贴板依赖，直接通过数组导出文本（稳定性最高，推荐）
  该方案完全不调用系统剪贴板，不会被其他软件干扰，导出的文本格式与剪贴板复制的制表符分隔格式完全一致，满足BCP上传的特殊字符保留要求。核心实现逻辑是先将目标范围数据读入内存数组，逐行拼接为制表符分隔的文本后直接写入目标txt文件。
• 方案2：保留原有剪贴板逻辑，增加重试与等待机制
  在复制操作后增加短时间等待，同时给GetFromClipboard方法增加3-5次重试，每次重试间隔100-200ms，可覆盖绝大多数剪贴板临时锁定、操作时序不匹配的场景；同时显式创建MSForms.DataObject对象，修正范围引用错误，避免硬编码Sheet2导致的复制范围异常。

参考修正代码（带重试机制的兼容版本） #

' 新增API声明用于毫秒级等待，放在模块顶部
#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Public Sub ExportSheetToSQL(Tabname As String, Filename As String, Tablename As String, firstRow As String)
    Dim WS As Excel.Worksheet
    Dim SaveToDirectory As String
    Dim CurrentWorkbook As String
    Dim CurrentFormat As Long
    Dim extnsion  As String
    Dim CVSWorkbook As Workbook
    Dim lastRowIndex As Long
    Dim clipObj As Object
    Dim fso As Object
    Dim ts As Object
    Dim retryCount As Integer
    Const MAX_RETRY As Integer = 5
    Const RETRY_WAIT As Long = 200

    Application.DecimalSeparator = "."
    Application.UseSystemSeparators = False
    Application.ScreenUpdating = False

    CurrentWorkbook = ThisWorkbook.FullName
    CurrentWorkbookName = ThisWorkbook.Name
    CurrentFormat = ThisWorkbook.FileFormat

    SaveToDirectory = GetTempDirectory & "\"
    extnsion = SaveToDirectory & Filename & ".txt"

    Set CVSWorkbook = Workbooks.Add
    With CVSWorkbook
        .Title = "CVS"
        .Subject = "CVS"
        .SaveAs Filename:=SaveToDirectory & "XLS" & Filename & ".xls"
    End With

    Workbooks(CurrentWorkbookName).Activate
    ' 修正原代码硬编码Sheet2的问题，明确复制当前传入的目标工作表
    Set WS = Worksheets(Tabname)
    WS.Copy Before:=CVSWorkbook.Sheets(1)
    
    lastRowIndex = WS.Range("A200000").End(xlUp).Row

    Application.CutCopyMode = False
    ' 明确复制目标工作表的已用范围
    WS.UsedRange.Copy
    ' 等待复制操作完成
    Sleep 100

    ' 显式创建剪贴板对象与文件对象，增加重试逻辑
    Set clipObj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.createtextfile(extnsion, True, True) ' 最后一个参数设为True以Unicode格式写入，避免特殊字符乱码

    retryCount = 0
    Do
        On Error Resume Next
        clipObj.GetFromClipboard
        If Err.Number = 0 Then
            ts.Write clipObj.GetText
            Exit Do
        End If
        Err.Clear
        retryCount = retryCount + 1
        Sleep RETRY_WAIT
    Loop While retryCount < MAX_RETRY
    On Error GoTo 0

    ts.Close
    Application.CutCopyMode = False

    TargetWorkbook = CVSWorkbook.FullName
    User = Environ("Username") ' 补充原代码缺失的用户名获取逻辑
    CVSWorkbook.Close savechanges:=True

    ' 恢复系统设置
    Application.UseSystemSeparators = True
    Application.ScreenUpdating = True

    If retryCount >= MAX_RETRY Then
        MsgBox "剪贴板访问失败，导出终止，请关闭其他占用剪贴板的程序后重试", vbExclamation
        Exit Sub
    End If
   
    'BCP UPLOAD CODE
End Sub

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