为 PowerPoint 优化 VBA 宏答案

【问题标题】：Optimizing VBA macro for PowerPoint为 PowerPoint 优化 VBA 宏
【发布时间】：2017-08-07 15:12:21
【问题描述】：

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

我的 powerpoint 大约有 25 张幻灯片，它已经超过了第 7 张幻灯片。通常在我格式化时它会崩溃。我为我使用的每个宏添加了 3 个基本布局，并在幻灯片 8 和 9 中显示了崩溃的位置。

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

代码：

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

【问题讨论】：

有我们可以看到的代码吗？
@NickSlash 我已经添加了我使用的代码的基本布局。 create_Slide# 宏只需复制图表和表格，然后粘贴到带有格式的新幻灯片上。
目前无法对其进行测试，但您可以尝试减慢执行速度（在 create_slide 调用之间进行睡眠/doevents 类型的操作）或调整您的代码，以便创建工作表的宏返回一些表明它已完成的内容并为下一个命令做好准备。
首先，在开始用数据填充文件之前保存文件 -> 在磁盘上创建文件，提前操作系统文件行为。循环宏调用，而不仅仅是静态调用。如果您发布宏代码，我们可以看看。由于PP崩溃，不是excel，问题应该出在宏代码上。见@NickSlash评论
@NickSlash 我现在添加了 msgbox 以减慢代码速度，但它仍然崩溃。我也上传了代码。正如我在问题中解释的那样，我使用 3 个宏模板。当我必须通过属性时，我将如何循环？

标签： excel optimization runtime powerpoint vba

【解决方案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

【讨论】：