Modification liaisons dans Powerpoint

Le 04/03/2016 à 16:44

Bonjour à tous,

J'ai trouvé du code pour mettre à jour les liaisons d'un fichier Powerpoint 2010

Sub MàJPowerpoint()
  Dim OldLink As String
  Dim Ppt As New PowerPoint.Application
  Dim PptPres As PowerPoint.Presentation
  Dim ObjSld As Slide
  Dim ObjShp As Shape
  Dim Fso As New FileSystemObject
  Dim sPathXls As String, sFicXls As String
  Dim NewLink As String
  Dim sPathPPt As String, sFicPpt As String

  ' 1) Copier le fichier TM1 en local
  sPathXls = ThisWorkbook.Sheets("Menu").Range("B1").Value
  If Right(sPathXls, 1) <> "\" Then sPathXls = sPathXls & "\"
  sFicXls = ThisWorkbook.Sheets("Menu").Range("B2").Value
  ' Déplacer le fichier en local
  Application.StatusBar = "Déplacement du fichier : " & sPathXls & sFicXls & " sur D:\"
  NewLink = "D:\" & sFicXls
  Fso.CopyFile sPathXls & sFicXls, NewLink
  ' Ouvrir le Powerpoint et modifier les liens
  sPathPPt = ThisWorkbook.Sheets("Menu").Range("B3").Value
  If Right(sPathPPt, 1) <> "\" Then sPathPPt = sPathPPt & "\"
  sFicPpt = ThisWorkbook.Sheets("Menu").Range("B4").Value
  ' Créer l'objet Powerpoint
  Application.StatusBar = "Ouverture de la présentation : " & sPathPPt & sFicPpt
  Set Ppt = CreateObject("PowerPoint.Application")
  Set PptPres = Ppt.Presentations.Open(Filename:=sPathPPt & sFicPpt)
  Ppt.Visible = True: Ppt.Activate
  'loop on each slides, and on each shapes
  For Each ObjSld In PptPres.Slides
    ObjSld.Select
    For Each ObjShp In ObjSld.Shapes
      If ObjShp.Type = msoLinkedOLEObject Then
        OldLink = ObjShp.LinkFormat.SourceFullName
        If InStr(1, OldLink, "Maquette") > 0 Then
          ' Inscrire l'ancien lien
          ThisWorkbook.Sheets("Menu").Range("C" & _
                                            ThisWorkbook.Sheets("Menu").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Row).Value
          ' Remplacer l'ancien lien par le nouveau
          If NewLink <> OldLink Then
            ObjShp.LinkFormat.SourceFullName = NewLink
            ObjShp.LinkFormat.Update
            ' Inscrire l'ancien lien
            ThisWorkbook.Sheets("Menu").Range("D" & _
                                              ThisWorkbook.Sheets("Menu").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Row).Value

          End If
        End If
      End If
SuiteSlide:
    Next ObjShp
    On Error GoTo 0
  Next ObjSld
End Sub

Mon problème c'est que j'ai une erreur 13 sur la ligne

 For Each ObjShp In ObjSld.Shapes

Et je n'arrive pas à comprendre pourquoi

Si quelqu'un pouvait m'aider

Le 04/03/2016 à 18:17

Bonjour,

bon je suppose que tu n'as pas lu tous le message d'erreur et qu'Erreur 13 c'est "incompatibilité de type" .. ( je sais pas comment vous faites pour mémoriser tout ces numéros d'erreurs ?? )

en pilotant powerpoint depuis Excel tu manipule des objets Excel et des Objets powerpoint ... tes "shape" d'excel sont semble t'il différent que ceux de powerpoint ...

essai un truc du genre :

  Dim ObjShp As Powerpoint.Shape
Le 04/03/2016 à 18:27

Salut Pierre.jy et merci

Dire que j'ai buté dessus au moins 2 heures, et laissé tomber pour finir

C'était bien ça, je n'avais pas vu mon erreur

Voici le bon code, car il y avait un autre bug pour le remplacement du lien 

' Activer la référence : Microsoft PowerPoint 14.0 Object Libray
Sub MàJPowerpoint()
  Dim OldLink As String
  Dim Ppt As New PowerPoint.Application
  Dim PptPres As PowerPoint.Presentation
  Dim ObjSld As PowerPoint.Slide
  Dim ObjShp As PowerPoint.Shape
  Dim Fso As New FileSystemObject
  Dim sPathXls As String, sFicXls As String
  Dim NewFicPath As String, NewLink As String
  Dim sPathPPt As String, sFicPpt As String
  Dim nLig As Long
  ' Mettre Excel en calcul Manuel
  Application.Calculation = xlCalculationManual
  ' 1) Copier le fichier TM1 en local
  sPathXls = ThisWorkbook.Sheets("Menu").Range("B1").Value
  If Right(sPathXls, 1) <> "\" Then sPathXls = sPathXls & "\"
  sFicXls = ThisWorkbook.Sheets("Menu").Range("B2").Value
  ' Déplacer le fichier en local
  Application.StatusBar = "Copie du fichier maquette : " & sPathXls & sFicXls & " sur D:\"
  NewFicPath = "D:\" & sFicXls
  Fso.CopyFile sPathXls & sFicXls, NewFicPath
  ' Ouvrir le Powerpoint et modifier les liens
  sPathPPt = ThisWorkbook.Sheets("Menu").Range("B3").Value
  If Right(sPathPPt, 1) <> "\" Then sPathPPt = sPathPPt & "\"
  sFicPpt = ThisWorkbook.Sheets("Menu").Range("B4").Value
  ' Créer l'objet Powerpoint
  Application.StatusBar = "Ouverture de la présentation : " & sPathPPt & sFicPpt
  Set Ppt = CreateObject("PowerPoint.Application")
  Set PptPres = Ppt.Presentations.Open(Filename:=sPathPPt & sFicPpt)
  Ppt.Visible = True: Ppt.Activate
  'loop on each slides, and on each shapes
  For Each ObjSld In PptPres.Slides
    Ppt.Activate: ObjSld.Select
    Application.StatusBar = "Mise à jour SLIDE n° " & ObjSld.SlideNumber & " sur " & PptPres.Slides.Count
    For Each ObjShp In ObjSld.Shapes
      If ObjShp.Type = msoLinkedOLEObject Then
        ' Récupérer l'ancien lien
        OldLink = ObjShp.LinkFormat.SourceFullName
        ' Si ce lien contient le terme Maquette et pointe vers le serveur
        If InStr(1, OldLink, "Maquette Reporting") > 0 And InStr(1, OldLink, "\\", vbTextCompare) > 0 Then
          ' Récupérer uniquement le chemin du lien
          sPathXls = Left(OldLink, InStrRev(OldLink, "\"))
          ' Remplacer ce chemin par le chemin en local
          NewLink = Replace(OldLink, sPathXls, "D:\")
          ' Pour mémo, inscrire l'ancien lien
          nLig = ThisWorkbook.Sheets("Menu").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Row
          ThisWorkbook.Sheets("Menu").Range("C" & nLig).Value = OldLink
          ' Remplacer l'ancien lien par le nouveau si différend
          If NewLink <> OldLink Then
            ObjShp.LinkFormat.SourceFullName = NewLink
            ' Pour mémo,Inscrire le nouveau lien
            nLig = ThisWorkbook.Sheets("Menu").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Row
            ThisWorkbook.Sheets("Menu").Range("D" & nLig).Value = NewLink
          End If
          ' Mettre à jour le lien
          ObjShp.LinkFormat.Update
        End If
      End If
SuiteSlide:
    Next ObjShp
    On Error GoTo 0
  Next ObjSld
  ' Remettre Excel en Calcul automatique
  Application.Calculation = xlCalculationAutomatic
End Sub

Cordialement

Le 04/03/2016 à 19:31

hé Bruno ... tu pourrais relire ta signature S.V.P ?

Le 19/04/2016 à 16:19

Bonjour,

Est-ce que votre macro fonctionne avec Excel 2013?

voici ce que je souhaite faire :

J'ai un fichier Powerpoint avec des liaisons Excel...Ce powerpoint tourne en continu et j'aimerai que mes liaisons s'effectuent automatiquement.

Est-ce possible de m'aider? SVP

Merci

Benjamin

Rechercher des sujets similaires à "modification liaisons powerpoint"