Modification liaisons dans Powerpoint
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
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
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
hé Bruno ... tu pourrais relire ta signature S.V.P ?
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