Excel的VBA创建PowerPoint演示文稿

Question

寻找在更新VBA的脚本完成以下（基本算法）一些帮助：

1. Excel模板与公式和宏创建了一个包含大约30图表
自定义报告
2. 宏称为“CreatePowerPointPresentation”用于在特定格式
3. 宏这些图表转移到一个特定的PowerPoint模板使用包含在模板的幻灯片创建第一个6张幻灯片
4. 宏则广告DS幻灯片（过渡和内容的幻灯片）

注意：基于从这个论坛

这个宏在Windows 7与Office 2013的伟大工程反馈此宏实际创建，但在Windows生成错误10，创建幻灯片8之后的Office 2016，在粘贴图表操作之一中随机创建，但绝不会从17幻灯片套牌的幻灯片10中滑过。

错误：

Runtime Error '-2147188160 (80048240) 
Method 'PasteSpecial'of object 'Shapes' failed. 

或者

Runtime Error '-2147023170 (800706be)': 
Automation Error 
The Remote procedure call failed. 

我不知道这是否是一个对象问题，或者说我缺少一些其它作品。下面

代码：

Sub CreatePowerPointPresentation() 
'========================================================================= 
'Create PowerPoint Presentation 
'Assigned to Index Tab 
'========================================================================== 


     Dim newPowerPoint As PowerPoint.Application 
     Dim activeSlide As PowerPoint.Slide 
     Dim CHT As Excel.ChartObject 
     Dim fmt As String 
     Dim hgt As String 
     Dim wth As String 


‘this code allows for the user to select whether to paste the charts as Excel Charts or PNG Formatted images. 

Sheets("Index").Select 
      If Range("AB7").Value = "Excel Charts" Then 
       fmt = ppPasteDefault 
      Else 
       fmt = ppPastePNG 
      End If 

    'Establishes the global height and width of the graphics or charts pasted from Excel 
     hgt = 280 
     wth = 710 

    'Look for existing instance 
     On Error Resume Next 
     Set newPowerPoint = GetObject(, "PowerPoint.Application") 
     On Error GoTo 0 

    'Create a new PowerPoint 
     If newPowerPoint Is Nothing Then 
     Set newPowerPoint = New PowerPoint.Application 
     End If 
    'Make a presentation in PowerPoint 
     If newPowerPoint.Presentations.Count = 0 Then 
     newPowerPoint.Presentations.Add 

     End If 

      'Show the PowerPoint 
      newPowerPoint.Visible = True 
      Application.EnableEvents = True 
      Application.ScreenUpdating = True 

      'Apply Template & Create Title Slide 1 

      newPowerPoint.ActivePresentation.ApplyTemplate Application.DefaultFilePath & "\file.potx" 

      'Set presentation to be 16x9 
      'AppActivate ("Microsoft PowerPoint") 
       With newPowerPoint.ActivePresentation.PageSetup 
       .SlideSize = ppSlideSizeOnScreen16x9 
       .FirstSlideNumber = 1 
       .SlideOrientation = msoOrientationHorizontal 
       .NotesOrientation = msoOrientationVertical 
       End With 
'Create Slides 2-6 these are imported from the template 
newPowerPoint.ActivePresentation.Slides.InsertFromFile Application.DefaultFilePath & "\File.potx", 0, 1 

'Create Slide 7 

newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank 
newPowerPoint.ActivePresentation.Slides(7).CustomLayout = newPowerPoint.ActivePresentation.SlideMaster.CustomLayouts(33) 
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count) 

With newPowerPoint.ActivePresentation.Slides(7) 
       .Shapes("Title 1").TextFrame.TextRange.Text = "Title1" 
End With 
      newPowerPoint.ActiveWindow.ViewType = ppViewSlide 

‘Create Slide 8 – Quad Chart Slide 

newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank 
newPowerPoint.ActivePresentation.Slides(8).CustomLayout = newPowerPoint.ActivePresentation.SlideMaster.CustomLayouts(13) 
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count 
newPowerPoint.ActivePresentation.Slides(8).Shapes("Title 1").TextFrame.TextRange.Text = "Title 1" 
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count) 
newPowerPoint.ActiveWindow.ViewType = ppViewSlide 

     'Upper Left 
      Sheets("Charts").Select 
      ActiveSheet.ChartObjects("Chart 3").Select 
      ActiveChart.ChartArea.Copy 
      newPowerPoint.ActiveWindow.ViewType = ppViewSlide 
      activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select 

      'Adjust the positioning of the Chart on Powerpoint Slide 
      newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5 
      newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 75 
      newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse 
      newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145 
      newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 345 

     'Upper Right 
      Sheets("Charts").Select 
      ActiveSheet.ChartObjects("Chart 2").Select 
      ActiveChart.ChartArea.Copy 
      newPowerPoint.ActiveWindow.ViewType = ppViewSlide 
      activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select 

      newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 350 
      newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 75 
      newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse 
      newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145 
      newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 345 


     'Lower Left 
      Sheets("Charts").Select 
      ActiveSheet.ChartObjects("Chart 4").Select 
      ActiveChart.ChartArea.Copy 
      newPowerPoint.ActiveWindow.ViewType = ppViewSlide 
      activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select 

      newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5 
      newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 230 
      newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse 
      newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145 
      newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 690 


‘More slides…… 

    Application.EnableEvents = True 
    Application.ScreenUpdating = True 
    Set activeSlide = Nothing 
    Set newPowerPoint = Nothing 

End Sub 

Answer 1

这听起来像是我在那里需要更多的时间来从Windows剪贴板比VBA复制的东西粘贴东西之前都面临着在PowerPoint可怕的代码失控的情况下代码执行，因此VBA代码提前运行并因此失败。要确认这是造成这种情况的原因，请在.Copy，.ViewType和.PasteSpecial行上放置一些断点，并查看它是否仍然无法完整收集幻灯片。如果不是，请尝试在.Copy和.ViewType行之后添加一些DoEvents行，如果这样做没有帮助，则注入延迟一两秒而不是DoEvents。这至少会证实假设是否正确。