Cookies op Tweakers

Tweakers maakt gebruik van cookies, onder andere om de website te analyseren, het gebruiksgemak te vergroten en advertenties te tonen. Door gebruik te maken van deze website, of door op 'Ga verder' te klikken, geef je toestemming voor het gebruik van cookies. Wil je meer informatie over cookies en hoe ze worden gebruikt, bekijk dan ons cookiebeleid.

Meer informatie

[VBA] Powerpoint macro dia merge neemt achtergrond niet mee

Pagina: 1
Acties:

  • Matthijz98
  • Registratie: januari 2013
  • Laatst online: 15:19
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:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
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

Pagina: 1


Apple iPhone X Google Pixel 2 XL LG W7 Samsung Galaxy S9 Google Pixel 2 Far Cry 5 Microsoft Xbox One X Apple iPhone 8

© 1998 - 2017 de Persgroep Online Services B.V. Tweakers vormt samen met o.a. Autotrack en Hardware.Info de Persgroep Online Services B.V. Hosting door True

*