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。這至少會證實假設是否正確。