Excel VBA that Opens a ppt file and splits file out

[bbrimberry]

Hello, Best VBAers around.

I am hoping someone out there can help me.

I have some excel vba code that opens a ppt file and splits it into parts based on a textbox value.
I need to keep the original formatting of the presentation the same.
sometimes it runs fine, other times I get an error that says " Something went wrong that might make PowerPoint Unstable"

any words of wisdom would be greatly appreciated

Sub CopySlides()

 

Dim pptApp As PowerPoint.Application

Dim pptPres As PowerPoint.Presentation

Dim newPres As PowerPoint.Presentation

Dim slide As PowerPoint.slide

Dim subbanner As PowerPoint.shape

Dim lastSubbannerText As String

Dim filePath As String

 

 

'Open the PowerPoint presentation

Set pptApp = CreateObject("PowerPoint.Application")

 

 

filePath = Range("a12").Value

Set pptPres = pptApp.Presentations.Open(filePath)

 

 

 


 

'Create a new presentation

Set newPres = pptApp.Presentations.Add

 

'Loop through each slide in the presentation

For Each slide In pptPres.Slides

'Find the subbanner shape on the slide

Set subbanner = slide.Shapes.Range(Array("subbanner")).Item(1)

'If the subbanner text on the current slide is different from the last slide, save and close the current presentation and create a new one

If subbanner.TextFrame.TextRange.Text <> lastSubbannerText Then

'Save and close the current presentation

'newPres.SaveAs "C:\Path\To\Save\Presentations" & lastSubbannerText & ".pptx"

'newPres.Close

'Create a new presentation

Set newPres = pptApp.Presentations.Add

End If

'Copy the slide to the clipboard

slide.Copy

'Paste the slide into the new presentation with the source formatting

pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")

'newPres.Item(1).Slides.Item(newPres.Item(1).Slides.Count).Design = pptPres.Slides.Item(i).Design

'Save the text of the current subbanner for comparison with the next slide

lastSubbannerText = subbanner.TextFrame.TextRange.Text

Next

 

'Save and close the final presentation

'newPres.SaveAs "C:\Path\To\Save\Presentations" & lastSubbannerText & ".pptx"

'newPres.Close

 

End Sub

 

[Domenic]

Try pausing your macro and calling DoEvents after you copy, and after you paste. So, for example, first add the following code to your module...

Sub PauseMacro(ByVal secs As Long)

    Dim endTime As Single
    endTime = Timer + secs
    
    Do
        DoEvents
    Loop Until Timer > endTime
    
End Sub

Then in your code would have the following...

'your code
'
'

slide.Copy

PauseMacro 3 'seconds

pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")

PauseMacro 3 'seconds

'
'
'

Note that the macro is paused for 3 seconds each time PauseMacro is called. However, you might find that a 1 second delay will suffice.

Hope this helps!

 

[bbrimberry]

thanks for your reply.
i will try this out!

 

[bbrimberry]

At first glance, this seems to have solved the issue.
I'm going to keep testing, but I cannot thank you enough.
I had been working on this off and on for a week or so.

 

[Domenic]

That's great, and thanks for your feedback.

Cheers!