Macro qui unlink tous les objets de tous les PPT d'un folder

Bonjour à vous tous,

Je débarque sur le forum avec mes skills de débutante aha. J'espère que vous pourrez m'aider :)

J'essaye de compiler une macro à lancer via un bouton Excel, qui ouvrira un à un tous les .ppt dans le fichier actuel (current folder), qui BreakLink tous les objets puis les fermera.

Un message apparait ensuite sur Excel.

Je n'arrive pas à trouver l'erreur dans mon code suivant :

Sub ForEachPowerpoint()

Dim rayFileList() As String

    Dim FolderPath As String

    Dim FileSpec

    Dim strTemp As String

    Dim x As Long

    FolderPath = "\\emplacement\xxxxxxxx\"   'J'ai masqué le nom de l'emplacement ici

    FileSpec = "*.ppt"

    ReDim rayFileList(1 To 1) As String

    strTemp = Dir$(FolderPath & FileSpec)

    While strTemp <> ""    

        rayFileList(UBound(rayFileList)) = FolderPath & strTemp

        ReDim Preserve rayFileList(1 To UBound(rayFileList) + 1) As String

        strTemp = Dir

Wend

If UBound(rayFileList) > 1 Then

        For x = 1 To UBound(rayFileList) - 1

            Call MyMacro(rayFileList(x))

        Next x

  End If

End Sub

Sub MyMacro(strMyFile As String)

    Dim oPresentation As Presentation

    Set oPresentation = Presentations.Open(strMyFile)

    With oPresentation

    Dim oSld As Slide

    Dim oSh As Shape

    For Each oSld In ActivePresentation.Slides

        For Each oSh In oSld.Shapes

            If oSh.Type = msoLinkedOLEObject Then

                oSh.LinkFormat.BreakLink

            End If

        Next

    Next

    End With

    oPresentation.Save

    oPresentation.Close

 Next

MsgBox "UNLINK effectué"

End Sub

Je suis dessus depuis hier sans trouver ce qui cloche

Merci d'avance pour votre aide :)

bonjour,

tu ne nous dis pas quelle erreur tu reçois, ni sur quelle instruction.

as-tu vérifié que tu as bien fait référence à la librairie powerpoint (voir outils, références dans l'éditeur vba)

j'ai remarqué quelques problèmes de syntaxe et quelques oublis.

proposition de corrections, non testé.

Sub ForEachPowerpoint()
    Dim rayFileList() As String
    Dim FolderPath As String
    Dim FileSpec
    Dim strTemp As String
    Dim x As Long
    FolderPath = "\\emplacement\xxxxxxxx\"   'J'ai masqué le nom de l'emplacement ici
    FileSpec = "*.ppt*"
    ReDim rayFileList(1 To 1) As String
    strTemp = Dir$(FolderPath & FileSpec)
    Do While strTemp <> ""
        rayFileList(UBound(rayFileList)) = FolderPath & strTemp
        ReDim Preserve rayFileList(1 To UBound(rayFileList) + 1) As String
        strTemp = Dir
    Loop
    If UBound(rayFileList) > 1 Then
        For x = 1 To UBound(rayFileList) - 1
            Call MyMacro(rayFileList(x))
        Next x
    End If
End Sub

Sub MyMacro(strMyFile As String)

    Dim oPresentation As Presentation
    Dim oSld As Slide
    Dim oSh As Object
    Set pptapp = CreateObject("powerpoint.application")
    Set oPresentation = pptapp.Presentations.Open(strMyFile)
    With oPresentation
        For Each oSld In oPresentation.Slides
            For Each oSh In oSld.Shapes
                If oSh.Type = msoLinkedOLEObject Then
                    oSh.LinkFormat.BreakLink
                End If
            Next
        Next
    End With
    oPresentation.Saved = True
    oPresentation.Close
    MsgBox "UNLINK effectué"
End Sub

Bonjour H2so4 ,

Merci pour ta réponse complète :) !

Je n'avais pas de message d'erreur mais rien ne se passait, pas de résultats dans les powerpoints et pas de souris "loading".

J'ai utilisé tes corrections et ajouté la référence librairie powerpoint (je ne connaissais pas l'existence de ces références, merci !).

Maintenant le code s'éxecute, la souris tourne pour process, les messages s'affichent, mais en vérifiant les powerpoints, les objets sont toujours liés.

Le code tourne mais dans le vide, ou alors effectue mal la tâche.

Vois-tu des choses qui poseraient problème dans le code ?

Merci d'avance pour ton temps et tes réponses :) Elles m'aident beaucoup.

bonjour,

le problème doit se situer ici

For Each oSh In oSld.Shapes
                If oSh.Type = msoLinkedOLEObject Then
                    oSh.LinkFormat.BreakLink
                End If
            Next

la condition

oSh.Type = msoLinkedOLEObject

n'est probablement jamais remplie (pas sûr que ce soit le bon test, Mais je dois avouer que ma connaissance des objets powerpoint est limitée)

je suis également très étonné que tu n'aies aucun message d'erreur de compilation, avant même l'exécution donc, sur le code que tu as mis...

peux-tu mettre un exemple de fichier ppt dans lequel il faudrait supprimer les liens ?

Re-Bonjour,

Le code pour BreakLink marche au cas par cas quand je l'execute dans le powerpoint même que je souhaite BreakLinks.

Je viens de tester le code avec un seul powerpoint à BreakLinks, je vois la macro ouvrir et fermer le powerpoint mais le texte/tableaux sont toujours liés. (En double cliquant sur l'objet on retourne sur le document d'origine ou en ouvrant le powerpoint une fenetre pop nous demandant si l'on souhaite update les links, fenetre qui n'apparait pas si les objets ne sont plus liés et le double clique n'est plus censé fonctionner).

Voici le fichier powerpoint avec lequel j'ai testé de breaklink le tableau.

Je joins également le fichier excel avec le bouton et le code VBA (seul l'emplacement fictif est à changer).

Merci encore :) !

bonsoir,

une correction et une optimisation. testé avec succès sur le fichier pptx que tu as joint.

Sub ForEachPowerpoint()
    Dim pptapp As Object
    Dim rayFileList() As String
    Dim FolderPath As String
    Dim FileSpec
    Dim strTemp As String
    Dim x As Long
    Set pptapp = CreateObject("powerpoint.application")
    FolderPath = "\\emplacement\xxxxxxxx\"
    FileSpec = "*.ppt*"
    ReDim rayFileList(1 To 1) As String
    strTemp = Dir$(FolderPath & FileSpec)
    Do While strTemp <> ""
        rayFileList(UBound(rayFileList)) = FolderPath & strTemp
        ReDim Preserve rayFileList(1 To UBound(rayFileList) + 1) As String
        strTemp = Dir
    Loop
    If UBound(rayFileList) > 1 Then
        For x = 1 To UBound(rayFileList) - 1
            Call MyMacro(pptapp, rayFileList(x))
        Next x
    End If
    pptapp.Quit
    Set pptapp = Nothing
End Sub

Sub MyMacro(pptapp As Object, strMyFile As String)

    Dim oPresentation As Presentation
    Dim oSld As Slide
    Dim oSh As Object

    Set oPresentation = pptapp.Presentations.Open(strMyFile)
    With oPresentation
        For Each oSld In oPresentation.Slides
            For Each oSh In oSld.Shapes
                If oSh.Type = msoLinkedOLEObject Then
                    oSh.LinkFormat.BreakLink
                End If
            Next
        Next
    End With
    oPresentation.Save
    oPresentation.Close
End Sub

Superbe ! Ca fonctionne à merveille :)

Merci beaucoup pour ton temps et ton aide, elle m'a été précieuse.

Excellente fin de journée à toi.