Bonjour,
Ma présentation PowerPoint est liée à un fichier excel. Le nom de ce dernier change tous les mois. Du coup, j'utilise une macro pour modifier les liaisons automatiquement. Cependant, depuis que j'ai changé d'office pour 2013, ma macro ne fonctionne plus et je n'ai aucun message d'erreur. Pouvez vous m'aider, svp?
Voici la macro :
Sub Test()
Dim pwrPoint As PowerPoint.Application
Dim Prez As PowerPoint.Presentation
Dim targetMaj As String
Dim Presentation As String
Dim Forme As PowerPoint.Shape
Dim Diapo As PowerPoint.Slide
Dim PathPPT As String
Dim PathXLS As String
Dim oldSrc As String
'Chemin des fichiers (PowerPoint / Nouveau fichier Excel)
PathPPT = ActivePresentation.Path & "\"
PathXLS = ActivePresentation.Path & "\"
'Fichier PowerPoint
Presentation = "Présentation_03-2015.pptm"
'Le nouveau classeur lié
targetMaj = "Tableau_de_bord_2015-03.xlsx"
Set pwrPoint = CreateObject("PowerPoint.Application")
pwrPoint.Visible = msoTrue
Set Prez = pwrPoint.Presentations.Open(PathPPT & Presentation)
Dim ind As Integer
Dim Tmp As String
Dim Suffixe As String
'Boucle sur les Slide de la présentation
For Each Diapo In Prez.Slides
'Boucle sur les formes
For Each Forme In Diapo.Shapes
'Vérifie s'il s'agit d'un objet lié
If Forme.Type = msoLinkedOLEObject Then
'Vérifie si l'objet lié est un objet Excel
If Forme.OLEFormat.ProgID = "Excel.Sheet.8" Then
'Initialise les variables
Tmp = Forme.LinkFormat.SourceFullName
Suffixe = ""
oldSrc = Forme.LinkFormat.SourceFullName
'Recherche du suffixe (premier ! dans l)
ind = InStr(Tmp, "!")
If (ind > 0) Then
Suffixe = Right(Tmp, Len(Tmp) - ind + 1)
End If
'Recherche de l'ancien nom de fichier
ind = InStrRev(Forme.LinkFormat.SourceFullName, "\")
If (ind > 0) Then
oldSrc = Right(Forme.LinkFormat.SourceFullName, Len(Tmp) - ind)
End If
oldSrc = Replace(oldSrc, Suffixe, "")
'Corrige une erreur sur le nom de l'ancien fichier en cas de mauvais mappage
ind = InStr(Suffixe, "[")
If (ind > 0) Then
oldSrc = Right(Suffixe, Len(Suffixe) - ind)
ind = InStr(oldSrc, "]")
If (ind > 0) Then
oldSrc = Left(oldSrc, ind - 1)
End If
End If
'Remplace le nom de l'ancien fichier dans le suffixe
Suffixe = Replace(Suffixe, oldSrc, targetMaj)
'Modifie la source
Forme.LinkFormat.SourceFullName = PathXLS & targetMaj & Suffixe
'Mise à jour
Forme.LinkFormat.Update
End If
End If
Next
Next
'Prez.Save
'ferme la présentation
'Prez.Close
'ferme powerpoint
'pwrPoint.Quit
End Sub
Merci d'avance
Partager