通过 VBA 将大量图表从 Excel 复制并粘贴到 PowerPoint

Question

任务是遍历具有多张工作表的 Excel 工作簿，并将工作簿中包含的所有图表复制到 PowerPoint 演示文稿中，每张幻灯片一个图表，并且始终使用相同的布局。

Sub PPT_Example()
    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim sh As Worksheet
    Dim ch As ChartObject

    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
            Dim pptSlide As Slide
            Dim Title As Object
            Dim Box As Object
            Dim Txt As Object
            Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
            ch.Copy
            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
            'Insert Box
            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))
            Prop_Box.Name = "Box"
            pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
            pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
            
            'Insert the text box
            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"
            pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
            pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
            pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
            pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
            
            'Clear the Clipboard
            Dim oData   As New DataObject 'object to use the clipboard
            oData.SetText Text:=Empty 'Clear
            oData.PutInClipboard
        Next
    Next
End Sub

该代码适用于我的示例（2 张纸，总共 3 张图表），但如果我将其应用于真实的东西，它是一个工作簿，每张纸有 10-15 张纸和 8 张图表。 在某个（随机？）点，代码停止并给我这个错误。

运行时错误：
形状（未知成员）：请求无效。 剪贴板为空或包含可能无法粘贴到此处的数据。

我注意到代码更早崩溃了，我在幻灯片上放置的对象越多（这就是为什么我在示例中留下文本和框的原因，尽管并非绝对必要）。 鉴于此和错误消息，我认为剪贴板在每次循环后可能无法正确清除，因此我放入了一个部分来清除剪贴板，但它并没有解决问题。

Answer 1

复制图表后，尝试添加 DoEvents 并暂停宏几秒钟，然后将其粘贴到幻灯片中。 粘贴到幻灯片后也是如此。

因此，例如，首先添加以下函数来暂停您的代码。 . .

Sub PauseMacro(ByVal secs As Long)

    Dim endTime As Single
    endTime = Timer + secs
    
    Do
        DoEvents
    Loop Until Timer > endTime
    
End Sub

然后尝试这样的事情。 . .

            ch.Copy
            
            DoEvents
            
            PauseMacro 5 'pause for 5 seconds
            
            With pptSlide.Shapes.Paste
                DoEvents
                PauseMacro 5 'pause for 5 seconds
                .Top = Application.CentimetersToPoints(3.3)
                .Left = Application.CentimetersToPoints(0.76)
                .Width = Application.CentimetersToPoints(16)
                .Height = Application.CentimetersToPoints(10.16)
            End With

通过测试你可能会发现你可以暂停不到 5 秒，也许是 3 秒。

Answer 2

我的方法是将潜在的耗时操作拆分为单独的函数（请参阅下面的“'' Call as a Function”）。 当一个函数被调用，然后必须返回时，似乎 Excel/VBA/the-little-green-men-running-everything 确保它的任何操作都等到操作完成（图表完全添加到剪贴板，剪贴板内容完全粘贴，形状完全实例化等），然后继续。

这也意味着不必在执行期间强制执行可能不需要的延迟（通常建议的Do Until或Loop Until或Wait ）。

所以你的代码可能看起来像这样（警告：未经测试）

Sub PPT_Example()
    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim sh As Worksheet
    Dim ch As ChartObject

    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
            Dim pptSlide As Slide
            Dim Title As Object
            Dim Box As Object
            Dim Txt As Object
            Set pptSlide = NewSlide(pptPres) '' Call as a Function
            ch.Copy
            Dim shp As PowerPoint.Shape
            Set shp = NewShape(pptSlide) '' Call as a Function
            With shp
                .Top = Application.CentimetersToPoints(3.3)
                .Left = Application.CentimetersToPoints(0.76)
                .Width = Application.CentimetersToPoints(16)
                .Height = Application.CentimetersToPoints(10.16)
            End With
        'Insert Box
        Set Box = NewBox(pptSlide) '' Call as a Function
        Prop_Box.Name = "Box"
        pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
        pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
        
        'Insert the text box
        Set Txt = NewTextBox(pptSlide) '' Call as a Function
        Txt.Name = "Txt"
        pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
        pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
        pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
        pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
        
        'Clear the Clipboard
        Dim oData   As New DataObject 'object to use the clipboard
        oData.SetText Text:=Empty 'Clear
        oData.PutInClipboard
        Next
    Next
End Sub

Function NewSlide(pptPres As PowerPoint.Presentation) As PowerPoint.Slide
    Set NewSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
End Function

Function NewShape(pptSlide As PowerPoint.Slide) As PowerPoint.Shape
    Set NewShape = pptSlide.Shapes.Paste
End Function

Function NewBox(pptSlide As PowerPoint.Slide) As Object
    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))
End Function

Function NewTextBox(pptSlide As PowerPoint.Slide) As Object
    Set NewTextBox = 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))
End Function