Sub UpdateLinks()
Dim oldPath As String, newPath As String, oldName As String, newName As String, oldLink As String, newLink As String
Dim pptPres As Presentation, pptSlide As Slide, pptShape As Shape, myFso As Object
Dim Message As String
Message = "Liens traités :" & Chr(10)
oldPath = "\2013\Janvier\"
newPath = "\2013\Février\"
oldName = "Jan"
newName = "Fev"
Set myFso = CreateObject("Scripting.FileSystemObject")
'loop on each slides, and on each shapes
Set pptPres = ActivePresentation
For Each pptSlide In pptPres.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.Type = msoLinkedOLEObject Then 'if it is a "linked object" then
oldLink = pptShape.LinkFormat.SourceFullName 'get curent path
newLink = Replace(Replace(oldLink, oldPath, newPath), oldName, newName) 'compute new path
If newLink <> oldLink Then
If Not myFso.FileExists(Left(newLink, InStr(1, newLink, "!") - 1)) Then 'check new path validity
MsgBox "File not found ! (" & newLink & ")", vbCritical, "Error"
Else
Message = Message & oldLink & " - " & newLink & chr(10)
pptShape.LinkFormat.SourceFullName = newLink 'modify the link
pptShape.LinkFormat.Update 'update the link
End If
End If
End If
Next pptShape
Next pptSlide
MsgBox Message
End Sub