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