Option Explicit
Sub CompilerPPT()
Dim PPTfile As String, chemin As String, NomCompilation As String, Z As Integer, x As Integer
chemin = "E:\ZZ_Tempo\Forums\test2\"
NomCompilation = chemin & "Tout.pptx"
If Dir(NomCompilation) <> "" Then Kill NomCompilation
PPTfile = Dir(chemin & "*.pptx")
x = 0
Do While PPTfile <> ""
x = x + 1
Presentations.Open chemin & PPTfile
Call DelateLinks(ActivePresentation)
If x > 1 Then
Z = ActivePresentation.Slides.Count
ActivePresentation.Slides.Range(Array(1, Z)).Copy
ActivePresentation.Close
ActivePresentation.Slides.Paste
End If
PPTfile = Dir
Loop
'Ligne ne fonctionne pas
'ActivePresentation.SaveAs NomCompilation, ppSaveAsDefault
End Sub
Sub DelateLinks(pptPres As Presentation)
Dim pptSlide As Slide, pptShape As Shape, myFso As Object
Set myFso = CreateObject("Scripting.FileSystemObject")
'loop on each slides, and on each shapes
For Each pptSlide In pptPres.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.Type = msoLinkedOLEObject Then 'object lié
If InStr(pptShape.LinkFormat.SourceFullName, ".xlsx") > 0 Then 'liaison Excel
pptShape.LinkFormat.BreakLink
End If
End If
Next pptShape
Next pptSlide
End Sub
