[VBA] Powerpoint macro dia merge neemt achtergrond niet mee

[Matthijz98]

Beste Tweakers

Ik heb een macro gemaakt(met wat hulp van google) om alle .pptx samen te voegen in een bestand.
Deze macro werkt prima in de zin van alle text komt netjes in een bestand.
Alleen wordt de opmaak van de source dia niet goed mee genomen, een aantal files maken gebruik van een thema maar als deze worden geïmporteerd is het thema weg de content is er wel gewoon nog. Ook zijn er een aantal files die een foto als achtergrond hebben ook deze foto's worden niet mee genomen naar het nieuwe bestand.

Is het mogelijk om de dia's te importen met de source styles.

code:

Sub InsertAllSlides()
'  Insert all slides from all presentations in the same folder as this one
'  INTO this one; do not attempt to insert THIS file into itself, though.
   Dim Pre As Presentation
   
    Dim vArray() As String
    Dim x As Long
 
    ' Change "*.PPT" to "*.PPTX" or whatever if necessary:
   EnumerateFiles ActivePresentation.Path & "\", "*.pptx", vArray
 
    With ActivePresentation
        For x = 1 To UBound(vArray)
            If Len(vArray(x)) > 0 Then
                .Slides.InsertFromFile vArray(x), .Slides.Count
            End If
        Next
    End With
   
      Dim prs As Presentation
 
      On Error Resume Next
   
      For Each prs In Presentations
        prs.Save
      Next prs
     
      ActivePresentation.SlideShowSettings.ShowType = ppShowTypeKiosk
     
      With Application.ActivePresentation
 
        If Not .Saved And .Path <> "" Then .Save
 
    End With
End Sub
 
Sub EnumerateFiles(ByVal sDirectory As String, _
    ByVal sFileSpec As String, _
    ByRef vArray As Variant)
    ' collect all files matching the file spec into vArray, an array of strings
 
    Dim sTemp As String
    ReDim vArray(1 To 1)
 
    sTemp = Dir$(sDirectory & sFileSpec)
    Do While Len(sTemp) > 0
        ' NOT the "mother ship" ... current presentation
       If sTemp <> ActivePresentation.Name Then
            ReDim Preserve vArray(1 To UBound(vArray) + 1)
            vArray(UBound(vArray)) = sDirectory & sTemp
        End If
        sTemp = Dir$
    Loop
 
End Sub