Attribute VB_Name = "ChangeLinks"
Sub ChangeOLELinks()
' Note: this will only work in PPT 2000 and later

    Dim oSld As Slide
    Dim oSh As Shape
    Dim sOldFile As String
    Dim sNewFile As String

    'Get the name of the excel file (ppt filename.xls)
    sNewFile = Left(ActivePresentation.FullName, Len(ActivePresentation.FullName) - 3) & "xls"
    
    sNewFileName = Left(ActivePresentation.Name, Len(ActivePresentation.Name) - 3) & "xls"
    'Debug.Print sNewFileName
    
    'Initialize object FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")

    'Check Excel file existence
    If FSO.FileExists(sNewFile) Then

        On Error GoTo ErrorHandler
        For Each oSld In ActivePresentation.Slides
            For Each oSh In oSld.Shapes
                ' Change only linked OLE objects
                If oSh.Type = msoLinkedOLEObject Then
                    On Error Resume Next
                    oSh.LinkFormat.AutoUpdate = ppUpdateOptionManual
                    sOldFile = ExtractPath(oSh.LinkFormat.SourceFullName)
                    aExtractName = Split(StrReverse(sOldFile), "\")
                    sOldName = StrReverse(aExtractName(0))
                    'Replace old path & file by new ones
                    oSh.LinkFormat.SourceFullName = Replace(oSh.LinkFormat.SourceFullName, sOldFile, sNewFile)
                    oSh.LinkFormat.SourceFullName = Replace(oSh.LinkFormat.SourceFullName, sOldName, sNewFileName)
                    On Error GoTo ErrorHandler
                 End If
            Next    ' shape
        Next    ' slide
    
        MsgBox ("Update successful. Please check. In case some links are not updated, run again the macro")
        
    Else
    
        MsgBox "Please check that " & sNewFile & " is on the same directory as your presentation", , "Update aborted : file not found"
    
    End If
    Set FSO = Nothing
        
NormalExit:
    Exit Sub
ErrorHandler:
    MsgBox ("Error " & Err.Number & vbCrLf & Err.Description)
    Resume NormalExit

End Sub

'Extracts path and filename of the ppt data link !!!For powerpoint data links ONLY !!!
Function ExtractPath(vPath)

    aSName = Split(vPath, "!")
    
    ExtractPath = aSName(0)

End Function