为 PowerPoint 优化 VBA 宏

Question

我正在从 VBA 编辑器创建一个 powerpoint，当我创建单独的幻灯片时，效果很好。但是，当我尝试一次创建它们时，PowerPoint 崩溃了。我通过在每张幻灯片的末尾设置 Application.CutCopyMode=False 来清除内存，并让 Application.Wait 持续 7 秒。

我的 powerpoint 大约有 25 张幻灯片，它已经在第 7 张幻灯片之后崩溃了。通常它在我格式化时崩溃。我为我使用的每个宏添加了 3 种基本布局，并在它崩溃的地方滑动了 8 和 9。

我使用的第一个宏复制了上次演示文稿中的一张幻灯片，然后粘贴到新的 powerpoint。
二贴一个Table
第三种粘贴 Table、图表和图片（仅带图片的幻灯片，否则此类幻灯片仅粘贴 table 和图表）。

代码：

Sub CreateNewPresentation()

  Application.ScreenUpdating = False
  Application.EnableEvents = False

  Dim ppApp As PowerPoint.Application
  Dim ppPres As PowerPoint.Presentation
  Dim slidesCount As Long

  If ppApp Is Nothing Then
     Set ppApp = New PowerPoint.Application
  End If

  Set ppPres = ppApp.Presentations.Add
  ppPres.SaveAs "FileName"

  ppApp.Visible = True
  slidesCount = ppPres.Slides.Count

  Call create_Slide1(slidesCount, ppPres, ppApp)
  slidesCount = ppPres.Slides.Count
  Application.CutCopyMode = False

 Call create_Slide2(slidesCount, ppPres)
  slidesCount = ppPres.Slides.Count
  Application.CutCopyMode = False

 Call create_Slide3(slidesCount, ppPres)
  slidesCount = ppPres.Slides.Count
  Application.CutCopyMode = False
  ppPres.Save
  ppPres.Close

 Call create_Slide8(slidesCount, ppPres)
  slidesCount = ppPres.Slides.Count
  Application.CutCopyMode = False

 Call create_Slide9(slidesCount, ppPres)
  slidesCount = ppPres.Slides.Count
  Application.CutCopyMode = False

  Application.ScreenUpdating = True
  Application.EnableEvents = True

End Sub

sub Create_Slide1(sldNum As Long, ppPrez As PowerPoint.Presentation, ppt As PowerPoint.Application)
   Dim myFile As String
   Dim ppSlide As PowerPoint.Slide
   Dim objPres As PowerPoint.Presentation
   Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank)
   ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper

   myFile:"File name and path....."
   Set objPres=ppt.Presentations.Open(myFile)
   objPres.Slides(1).Copy
   ppPrez.Slides.Paste Index:=sldNum+1
   objPres.Close
   ppPrez. Slides(sldNum+2).Delete
End Sub
Sub create_Slide2(sldNum As Long, ppPrez As PowerPoint.Presentation)
   Dim ppSlide As PowerPoint.Slide
   Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank)
   ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper
   ppSlide.Select
   ThisWorkbook.Worksheets("Sheet2").Activate
   ActiveSheet.Range(Cells(3, 2), Cells(27, 11)).Copy
   ppSlide.Shapes.Paste.Select
   With ppSlide.Shapes(1)
       .Top = ppPrez.PageSetup.SlideHeight / 20
       .Left = ppPrez.PageSetup.SlideWidth / 20
       .Height = 17 * (ppPrez.PageSetup.SlideHeight) / 20
       .Width = 9 * (ppPrez.PageSetup.SlideWidth / 10)
   End With

End Sub
sub create_Slide3(sldNum As Long, ppPrez As PowerPoint.Presentation)
    Dim ppSlide As PowerPoint.Slide
    Dim ppTextBox As PowerPoint.Shape
    Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank)
    ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper
    ppSlide.Select

    Set ppTextBox = ppSlide.Shapes.AddTextbox( _
    msoTextOrientationHorizontal, 0, 15, ppPrez.PageSetup.SlideWidth, 60)
    With ppTextBox.TextFrame
        .TextRange.Text = "Slide3"
        .TextRange.ParagraphFormat.Alignment = ppAlignCenter
        .TextRange.Font.Size = 20
        .TextRange.Font.Name = "Calibri"
        .VerticalAnchor = msoAnchorMiddle
    End With
    ThisWorkbook.Sheets("Sheet3").Activate
    ActiveSheet.Range(Cells(17, 10), Cells(19, 19)).Copy
    ppSlide.Shapes.Paste.Select
    With ppSlide.Shapes(2)
        .Width = (6 / 10) * ppPrez.PageSetup.SlideWidth
        .Left = (1 / 40) * ppPrez.PageSetup.SlideWidth
        .Top = (5 / 8) * ppPrez.PageSetup.SlideHeight
    End With
    Sheets("Sheet3").Shapes("Shape1").CopyPicture
    ppSlide.Shapes.Paste
    ppSlide.Shapes(4).Height = 850
    ppSlide.Shapes(4).Width = 275
    ppSlide.Shapes(4).Left = (6.2 / 10) * ppPrez.PageSetup.SlideWidth
    ppSlide.Shapes(4).Top = (1 / 10) * ppPrez.PageSetup.SlideHeight
End sub

sub create_Slide8(sldNum As Long, ppPrez As PowerPoint.Presentation)
   Dim ppSlide As PowerPoint.Slide
   Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank)
   ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper
   ppSlide.Select

   ThisWorkbook.Sheets("roll").Activate
   ActiveSheet.ChartObjects("35").Activate
   ActiveChart.ChartArea.Copy
   ppSlide.Shapes.Paste.Select
   With ppSlide.Shapes(1)
    .Left = 1 * (ppPrez.PageSetup.SlideWidth / 20)
    .Height = _
       ppPrez.PageSetup.SlideHeight / 2
    .Width = _
       9 * (ppPrez.PageSetup.SlideWidth / 10)
    .Top = 0
End With

   Application.Wait (Now + TimeValue("0:00:03"))
   Application.CutCopyMode = False
   MsgBox ("done")

   ActiveSheet.ChartObjects("40").Activate
   ActiveChart.ChartArea.Copy
   ppSlide.Shapes.Paste.Select
   With ppSlide.Shapes(2)
      .Left = 1 * (ppPrez.PageSetup.SlideWidth / 20)
      .Height = _
          ppPrez.PageSetup.SlideHeight / 2
      .Width = _
          9 * (ppPrez.PageSetup.SlideWidth / 10)
      .Top = _
          ppPrez.PageSetup.SlideHeight / 2
   End With

   Application.Wait (Now + TimeValue("0:00:07"))
   MsgBox ("done")
End Sub

sub create_Slide9(sldNum As Long, ppPrez As PowerPoint.Presentation, ppt As PowerPoint.Application)

  Dim ppSlide As PowerPoint.Slide
  Dim objPres As PowerPoint.Presentation
  Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank)
  ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper
  ppSlide.Select

  myFile = "File Path....same as above"
  Set objPres = ppt.Presentations.Open(myFile)
  objPres.Slides(8).Copy
  ppPrez.Slides.Paste Index:=sldNum + 1 'sometimes it fails here too because of a paste issue (Either vba doesn't like method or no where to paste too)
  objPres.Close
  ppPrez.Slides(sldNum + 2).Delete 
  MsgBox ("done")
  Application.Wait (Now + TimeValue("0:00:07"))
End Sub

Answer 1

我不确定，但我认为消息框正在阻塞。执行将停止，直到它被处理，所以不会给你的代码时间来恢复。

下面的代码应该可以工作，但我不太喜欢。在不修改您的其他一些功能代码的情况下，这是我能做的最好的。

希望您能看到代码背后的想法并改进它。理想情况下，它会使用循环并位于 CreateNewPresentation 子内部而不是递归函数。您可能只是将代码中的消息框替换为 Sleep 100 而不是使用我的代码（在将睡眠声明复制到您的模块之后）

PowerPoint 没有 ScreenUpdating 类型的交易，有些命令确实需要一段时间才能完成。在每张幻灯片之间使用睡眠可能有帮助，也可能没有帮助。在 create_slideN 宏中的某些函数调用之间放置一些 Sleep 可能是值得的。我从来没有自动化过 Powerpoint，所以不知道它是如何工作的。

Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)

Public CreationIndex As Integer
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim slideCount As Integer

Sub CreateNewPresentation()

  Application.ScreenUpdating = False
  Application.EnableEvents = False

    If ppApp Is Nothing Then
        Set ppApp = New PowerPoint.Application
    End If

    Set ppPres = ppApp.Presentations.Add
    ppPres.SaveAs "FileName"

    ppApp.Visible = True

    CreationIndex = 1

    Create CreationIndex ' start the ball rolling...

End Sub

Sub Create(i As Integer)
slidesCount = ppPres.Slides.Count
Select Case i
Case 1
    Call Create_Slide1(slidesCount, ppPres, ppApp)
Case 2
    Call create_Slide2(slidesCount, ppPres)
Case 3
    Call create_Slide3(slidesCount, ppPres)
Case Else
    MsgBox "Complete or Broken...", vbOKOnly
    Exit Sub
End Select

Application.CutCopyMode = False

Sleep 200 ' wait for a bit...

CreationIndex = CreationIndex + 1
Create CreationIndex

End Sub

为 PowerPoint 优化 VBA 宏

Optimizing VBA macro for PowerPoint

excel

optimization

powerpoint

vba

runtime