Optimizing VBA macro for PowerPoint - excel

Question

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.
The First Macro I use copies a slide from last presentation and
pastes to new powerpoint.
The Second Pastes a Table
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

Answer 1

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