我之前在处理大批量Office自动化任务时，也踩过一模一样的剪贴板坑——小批量测试完全正常，一到真实业务场景（十几张工作表、上百个图表）就随机崩溃，弹出那个烦人的“剪贴板为空或无法粘贴”错误。结合你的代码和问题描述，我来拆解下问题根源和靠谱的解决办法：

问题本质分析 #

这个Run-time error: Shapes (unknown member): Invalid request错误，核心原因有两个：

• 剪贴板的异步特性：复制图表后，系统需要时间把图表数据写入剪贴板，但你的代码没有等待这个过程完成，直接执行粘贴操作。小批量时系统能跟上节奏，大批量操作时就会出现“剪贴板还没准备好就粘贴”的情况；
• 现有剪贴板清空逻辑不可靠：用DataObject清空剪贴板的方式在Office频繁操作场景下非常不稳定，经常没法彻底清除之前的剪贴板内容，导致后续粘贴冲突。

解决方案 #

下面是针对性的修改方案，包含可靠的剪贴板清空、操作延迟和错误重试机制：

1. 添加Windows API剪贴板清空函数

先在模块顶部添加API声明（仅适用于Windows系统），这个方法比DataObject更底层，清空剪贴板的可靠性更高：

#If VBA7 Then
    Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hwnd As LongPtr) As Long
    Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
    Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
#Else
    Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
    Declare Function EmptyClipboard Lib "user32.dll" () As Long
    Declare Function CloseClipboard Lib "user32.dll" () As Long
#End If

Sub ClearClipboard()
    OpenClipboard 0&
    EmptyClipboard
    CloseClipboard
End Sub

2. 修改主代码：添加延迟、替换清空逻辑、增加错误重试

修改后的主函数会在复制后等待剪贴板就绪，用可靠的API清空剪贴板，并且对粘贴操作添加重试机制：

Sub PPT_Example()
    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim sh As Worksheet
    Dim ch As ChartObject
    Dim pptSlide As Slide
    Dim Box As Object
    Dim Txt As Object
    Dim retryCount As Integer ' 重试计数器
    
    On Error GoTo ErrorHandler ' 启用错误捕获
    
    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True
    Set pptPres = pptApp.Presentations.Add
    pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9
    
    For Each sh In ActiveWorkbook.Sheets
        For Each ch In sh.ChartObjects
            retryCount = 0
RetryPaste:
            Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
            
            ' 复制图表前先清空剪贴板，避免残留数据干扰
            ClearClipboard
            ch.Copy
            
            ' 等待剪贴板就绪（给系统足够时间写入数据）
            Do Until ClipboardReady()
                DoEvents
                Application.Wait Now + TimeValue("00:00:00.2") ' 等待0.2秒
            Loop
            
            ' 尝试粘贴，失败则重试最多2次
            On Error Resume Next
            With pptSlide.Shapes.Paste
                .Top = Application.CentimetersToPoints(3.3)
                .Left = Application.CentimetersToPoints(0.76)
                .Width = Application.CentimetersToPoints(16)
                .Height = Application.CentimetersToPoints(10.16)
            End With
            On Error GoTo ErrorHandler
            
            If Err.Number <> 0 Then
                retryCount = retryCount + 1
                If retryCount <= 2 Then
                    ' 删除创建的空幻灯片，重试
                    pptSlide.Delete
                    GoTo RetryPaste
                Else
                    Err.Raise Err.Number, Err.Source, Err.Description ' 超过重试次数，抛出错误
                End If
            End If
            
            ' 添加右侧矩形框
            Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
                Left:=Application.CentimetersToPoints(17.1), _
                Top:=Application.CentimetersToPoints(3.3), _
                Width:=Application.CentimetersToPoints(7.22), _
                Height:=Application.CentimetersToPoints(9.29))
            Box.Name = "Box" ' 修正原代码的Prop_Box拼写错误
            pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
            pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
            
            ' 添加文本框
            Set Txt = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
                Left:=Application.CentimetersToPoints(17.1), _
                Top:=Application.CentimetersToPoints(3.3), _
                Width:=Application.CentimetersToPoints(7.22), _
                Height:=Application.CentimetersToPoints(9.29))
            Txt.Name = "Txt"
            With Txt.TextFrame.TextRange
                .Font.Size = 14
                .Font.Bold = msoCTrue
                .Font.Name = "Arial"
                .Text = "Sample Text"
            End With
            
            ' 最后清空剪贴板
            ClearClipboard
        Next ch
    Next sh
    
    Exit Sub
    
ErrorHandler:
    MsgBox "操作出错：" & Err.Description & vbCrLf & "错误代码：" & Err.Number, vbCritical
    ' 清理资源
    If Not pptPres Is Nothing Then pptPres.Close SaveChanges:=False
    If Not pptApp Is Nothing Then pptApp.Quit
    Set pptPres = Nothing
    Set pptApp = Nothing
End Sub

' 辅助函数：检查剪贴板是否就绪
Function ClipboardReady() As Boolean
    Dim tempData As DataObject
    On Error Resume Next
    Set tempData = New DataObject
    tempData.GetFromClipboard
    ClipboardReady = (Err.Number = 0)
    Set tempData = Nothing
End Function

关键修改说明 #

• API清空剪贴板：替换原有的DataObject方式，彻底清空剪贴板，避免残留数据导致粘贴冲突；
• 剪贴板就绪检查：通过ClipboardReady函数判断剪贴板是否完成数据写入，确保粘贴时机正确；
• 错误重试机制：粘贴失败时最多重试2次，应对临时的系统资源繁忙问题；
• 修正原代码错误：原代码中Prop_Box.Name = "Box"是拼写错误，改为Box.Name = "Box"；
• 资源清理：错误捕获中添加了PPT资源的清理，避免异常退出时残留PPT进程。

额外注意事项 #

1. 确保VBA编辑器中已经引用了Microsoft PowerPoint xx.x Object Library（工具→引用）；
2. 如果是64位Office，要确保API声明使用PtrSafe（代码中已经做了版本判断）；
3. 批量操作时，建议关闭其他占用剪贴板的程序（比如微信、QQ等），减少干扰。

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