Optimizing VBA macro for PowerPoint

0
votes

I am creating a powerpoint from the VBA editor and when I create the individual slides, it works great. However, when I try to create them all at once, PowerPoint crashes. I clear memory by setting Application.CutCopyMode=False at the end of each slide and have Application.Wait for 7 seconds.

My powerpoint is going to be about 25 slides and its already crashing past slide 7. Usually it crashes when I am formatting. I have added in the 3 basic layouts for each Macro I use and slides 8 and 9 of where it crashes.

  1. The First Macro I use copies a slide from last presentation and pastes to new powerpoint.
  2. The Second Pastes a Table
  3. The Third Pastes a Table, Chart, and Picture (only slide with Picture, otherwise slides of this type paste a table and chart only).

Code:

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
1
exceloptimizationruntimepowerpointvba
Got any code we can see? – NickSlash
@NickSlash I have added the basic layout of the code I use. The create_Slide# macros simply copy a chart and table and pate onto a new slide with formatting. – Jack Armstrong
Can't test it at the moment, but you could try slowing down the execution (sleep/doevents type thing between create_slide calls) or adjusting your code so the macro creating the sheet returns something indicating it's complete and ready for the next command. – NickSlash
First, save the File before you start filling it with data -> creates the File on the disk, takes advance of the OS file behavior. Make a loop of the macro calls, not just static calls. If you post the macro code, we can have a look at that. Since PP crashes, not excel, the problem should be in the macro code.See @NickSlash comment – Git
@NickSlash I have added msgbox now to slow down the code, but it still crashes. I have also uploaded the code. I use 3 macro templates as I explain in the question. How would I loop when I have to pass through properties? – Jack Armstrong

1 Answers

1
votes

I'm not certain, but I think that message boxes are blocking. Execution is stopped until it's dealt with, so wont give your code time to recover.

The following code should work but I don't really like it. Its the best I can do without modifying some of your other functioning code too.

Hopefully you might see what the idea behind the code is and can improve on it. Ideally it would use a loop and be inside your CreateNewPresentation sub instead of a recursive function. You could potentially just replace the messageboxes in your code with Sleep 100 and not use my code (after copying the Sleep Declaration to your module)

PowerPoint doesn't have a ScreenUpdating type deal and some commands do take a while to complete. Using Sleep between each slide may help, it might not. It might be worth putting some Sleep's between some function calls in your create_slideN macros. I've never automated Powerpoint so dont know how it works.

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