Question

我正在从VBA编辑器创建一个powerpoint，当我创建单个幻灯片时，它的效果非常好。但是，当我尝试一次创建它们时，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

Answer 1

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

以下代码应该可以使用，但我真的不喜欢它。这是我能做的最好的事情，而无需修改你的其他一些功能代码。

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

PowerPoint没有ScreenUpdating类型的交易，有些命令需要一段时间才能完成。在每张幻灯片之间使用Sleep可能有所帮助，但可能没有。在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宏

1 个答案: