When movies are inserted into PowerPoint presentations, PowerPoint apparently always saves the absolute path to the media file. In case that the presentation is copied or moved to another computer, videos will no longer work. One work around is the Visual Basic script listed below. It iterates over all media objects, extracts the referenced filenames, searches for them either in the subfolders of the presentation (RelinkMoviesToDefaultLocation) or another folder chosen by the user (RelinkMoviesAndAskForLocation). When searching for the best match, the function GetBestMatchingFile requires at least that the filename (without path) matches exactly, but will return the longest match (i.e., matching most of the path).

• open the VBA editor (Tools→Macro→Visual basic editor)
• Add a new module (Insert→Module)
• Paste the code below inside that module

After this, you can simply run the macro's from within PP itself. Simply go to Tools→Macro→Macros and you can choose either RelinkMoviesToDefaultLocation or RelinkMoviesAndAskForLocation to run.

Copy and paste this code inside the VBA module.

Option Explicit

Public Const DefaultMovieSubFolder  As String = ""

'relinks all movies to the default subdirectory beneath the presentations location
'the name of the subdirectory is set in the DefaultMovieSubFolder constant
Public Sub RelinkMoviesToDefaultLocation()
    Dim folder As String
    folder = GetDir(ActivePresentation.FullName) & DefaultMovieSubFolder
    RelinkMovies folder
End Sub

'Ask the user for a directory and relinks all movie objects to that location
Public Sub RelinkMoviesAndAskForLocation()
    Dim folder As String
    folder = InputBox("Please enter target directory", , GetDir(ActivePresentation.FullName))
    If Len(folder) = 0 Then Exit Sub
    RelinkMovies folder
End Sub

Public Sub RelinkMovies(Target As String)
    If Len(Dir(Target, vbDirectory)) = 0 Then
        MsgBox "The target directory (" + Target + ") does not exist. Relinking cancelled"
        Exit Sub
    End If
   
    Dim sl As Slide, sh As Shape, count As Integer, relinked As Integer
    If Not Right$(Target, 1) = "\" Then Target = Target & "\"
    For Each sl In ActivePresentation.Slides
        For Each sh In sl.Shapes
            If IsMovie(sh) Then
                If Relink(sh, Target) Then relinked = relinked + 1
                count = count + 1
            End If
        Next
    Next
    MsgBox "Finished: " & count & " movie objects were checked and " & relinked & " were relinked"
End Sub

Private Function IsMovie(sh As Shape)
    On Error Resume Next
    IsMovie = sh.MediaType = ppMediaTypeMovie
End Function

Function Relink(sh As Shape, TargetDir As String) As Boolean
    Dim File As String, Current As String, ProposedFile As String
    
    File = sh.LinkFormat.SourceFullName
    Current = GetDir(File)
   
    ProposedFile = TargetDir & Mid$(File, Len(Current) + 1)
    ProposedFile = GetBestMatchingFile(TargetDir, File)
        
    If File = ProposedFile Then
        Exit Function 'no change made
    End If
        
    sh.LinkFormat.SourceFullName = ProposedFile
    Relink = True
End Function


Private Function GetDir(File As String) As String
    Dim i As Integer
    i = InStrRev(File, "\")
    If i = 0 Then
        GetDir = ""
    Else
        GetDir = Left$(File, i)
    End If
End Function

Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
    bIncludeSubfolders As Boolean)
    'Build up a list of files, and then add add to this list, any additional folders
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add the files to the folder.
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colDirList.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Build collection of additional subfolders.
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop
        'Call function recursively for each subfolder.
        For Each vFolderName In colFolders
            Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
        Next vFolderName
    End If
End Function

Public Function TrailingSlash(varIn As Variant) As String
    If Len(varIn) > 0& Then
        If Right(varIn, 1&) = "\" Then
            TrailingSlash = varIn
        Else
            TrailingSlash = varIn & "\"
        End If
    End If
End Function
Private Function GetBestMatchingFile(SearchDir As String, Filename As String) As String
    Dim colDirList As New Collection
    Dim varItem As Variant
    Call FillDir(colDirList, SearchDir, "*.*", True)
    
    Dim CurrentDir, FilenameOnly As String
    CurrentDir = GetDir(Filename)
    FilenameOnly = Mid$(Filename, Len(CurrentDir) + 1)
    
    Dim bestMatchingChars As Integer
    Dim bestMatchedString As String
    bestMatchingChars = 0
    bestMatchedString = Filename
    
    For Each varItem In colDirList
        Dim matchingChars As Integer
        Dim matchedString As String
        
        matchingChars = 0
        Dim lenVar As Integer
        Dim lenFile As Integer
        lenVar = Len(varItem)
        lenFile = Len(Filename)
        Do While (Mid$(Filename, Len(Filename) - matchingChars - 1) = Mid$(varItem, Len(varItem) - matchingChars - 1))
            matchingChars = matchingChars + 1
            If matchingChars >= lenVar - 1 Then Exit Do
            If matchingChars >= lenFile - 1 Then Exit Do
        Loop
        matchedString = varItem
        
        If (matchingChars > bestMatchingChars) And (matchingChars >= Len(FilenameOnly)) Then
            bestMatchingChars = matchingChars
            bestMatchedString = matchedString
        End If
'        Debug.Print varItem
    Next
    
'    Debug.Print "org: " & Filename
'    Debug.Print "best:" & bestMatchedString

    If bestMatchingChars = 0 Then
        MsgBox "Not found: " & Filename
    Else
        ' make path relative?
        bestMatchedString = Replace(bestMatchedString, SearchDir, "")
    End If
    

    GetBestMatchingFile = bestMatchedString
    
End Function