copying slides from pptm to embedded pptx using VBA PowerPoint

[CuriosityBug]

Hello,

I am trying to copy all slides present in .pptm file to an embedded .pptx (i.e hidden object) in current presentation, can anyone please help how to do this using VBA and then access that embedded PowerPoint or any useful links, that are useful to get the information/thoughts.

Thanks.:)

[Aussiebear]

Since this thread has no reply, then maybe this might be a solution.


Sub CopySlidesToEmbeddedPPTX()
Dim pptApp As Object 'As PowerPoint.Application
' Late binding
Dim currentPres As Presentation
Dim embeddedShape As Shape
Dim embeddedPres As Object
' As PowerPoint.Presentation
' Late binding
Dim sourcePres As Presentation
Dim sourceSlide As Slide
Dim i As Long
' Set references
Set currentPres = Application.ActivePresentation
' **Important:** You need to know the index or name of your embedded PowerPoint object.
' You can find this by selecting the embedded object in PowerPoint and checking
' its properties in the VBA Immediate window (e.g., ?ActiveWindow.Selection.ShapeRange(1).Name).
' Replace "Object 1" with the actual name or index if needed.
On Error Resume Next
Set embeddedShape = currentPres.Slides(1).Shapes("Object 1")
' Assuming it's on the first slide and named "Object 1"
If embeddedShape Is Nothing Then
Set embeddedShape = currentPres.Slides(1).Shapes(1)
' Try the first shape if name doesn't match
End If
On Error GoTo 0
If embeddedShape Is Nothing Then
MsgBox "Embedded PowerPoint object not found on the first slide.", vbExclamation
Exit Sub
End If
' Check if the embedded shape is an OLE object
If embeddedShape.Type <> msoOLEObject Then
MsgBox "Selected shape is not an OLE object.", vbExclamation
Exit Sub
End If
' Get the embedded PowerPoint Application object (late binding)
On Error Resume Next
Set pptApp = GetObject(, "PowerPoint.Application")
If Err.Number <> 0 Then
Set pptApp = CreateObject("PowerPoint.Application")
End If
On Error GoTo 0
' **Specify the full path to your .pptm file**
Dim sourceFilePath As String
sourceFilePath = "C:\Path\To\Your\SourcePresentation.pptm" ' **<-- CHANGE THIS**
On Error Resume Next
Set sourcePres = pptApp.Presentations.Open(sourceFilePath, msoFalse, msoFalse, msoFalse)
' Read-only, not visible
On Error GoTo 0
If sourcePres Is Nothing Then
MsgBox "Could not open the source presentation: " & sourceFilePath, vbCritical
If pptApp.Presentations.Count = 0 Then
pptApp.Quit
' Quit PowerPoint if it was newly created and no presentations are open
End If
Exit Sub
End If
' Activate the embedded object to get its Presentation
object embeddedShape.OLEFormat.DoVerb ppVerbOpen
' Or ppVerbPrimary
' Wait a short time for the embedded object to activate (optional but can be helpful)
Application.Wait (Now + TimeValue("0:00:01"))
' Get the Presentation object of the embedded object
On Error Resume Next
Set embeddedPres = embeddedShape.OLEFormat.Object
On Error GoTo 0
If embeddedPres Is Nothing Then
MsgBox "Could not access the embedded PowerPoint presentation.", vbCritical
sourcePres.Close
If pptApp.Presentations.Count = 0 Then
pptApp.Quit
End If
Exit Sub
End If
' Copy slides from the source to the embedded presentation
For i = 1 To sourcePres.Slides.Count
sourcePres.Slides(i).Copy
embeddedPres.Slides.Paste
Next i
' Clean up sourcePres.Close
' Optionally, you can deactivate the embedded object
embeddedShape.OLEFormat.DoVerb
ppVerbHide
MsgBox "Slides copied successfully to the embedded PowerPoint object.", vbInformation
' Quit the PowerPoint application if it was newly created and no other presentations are open
If pptApp.Presentations.Count = 1 And currentPres.Application Is Not pptApp Then
pptApp.Quit
End If
' Release object variables
Set pptApp = Nothing
Set currentPres = Nothing
Set embeddedShape = Nothing
Set embeddedPres = Nothing
Set sourcePres = Nothing
Set sourceSlide = Nothing
End Sub