Sub ScrubMetadataExcelRecursive()

Dim FileSystem As Object
Dim FolderName As String
Dim FolderPath As FileDialog


''''''''''''''''''''''''''''''''''''''''''''''
Set FolderPath = Application.FileDialog(msoFileDialogFolderPicker)
With FolderPath
    .AllowMultiSelect = False
    .Show
    FolderName = .SelectedItems(1)
End With
''''''''''''''''''''''''''''''''''''''''''''''

Set FileSystem = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = True
Application.StatusBar = "0     FILES DONE"
DoEvents
DoFolder FileSystem.GetFolder(FolderName)
Application.StatusBar = Application.StatusBar & " & FINISHED"
DoEvents
End Sub

Sub DoFolder(Folder)
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File As Object
    Dim WordFile As Object
    Dim PowerPointFile As Object
    Dim ExcelFile As Object
    
    Set WordFile = CreateObject("Word.Application")
    Set PowerPointFile = CreateObject("PowerPoint.Application")
    Set ExcelFile = CreateObject("Excel.Application")
    
    For Each File In Folder.Files
    If Left(File.Name, 2) = "~$" Then
        SetAttr File.Path, vbNormal
        Kill (File.Path)
    Else
Select Case True
    Case Right(File.Name, 5) Like "*.xls" Or Right(File.Name, 5) Like ".xlsx" Or Right(File.Name, 5) Like ".xlsm"
        ExcelFile.Workbooks.Open (File.Path)
        With ExcelFile.ActiveWorkbook
            .RemoveDocumentInformation (99)
            .Save
            .Close
        End With
    Case Right(File.Name, 5) Like "*.doc" Or Right(File.Name, 5) Like ".docx" Or Right(File.Name, 5) Like ".docm"
        WordFile.documents.Open (File.Path)
        With WordFile.ActiveDocument
            .RemoveDocumentInformation (99)
            .Save
            .Close
        End With
    Case Right(File.Name, 5) Like "*.ppt" Or Right(File.Name, 5) Like ".pptx" Or Right(File.Name, 5) Like ".pptm"
'        PowerPointFile.Visible = True
        PowerPointFile.Presentations.Open (File.Path)
        With PowerPointFile.ActivePresentation
            .RemoveDocumentInformation (99)
            .Save
            .Close
        End With
End Select
    End If
    Application.StatusBar = (Val(Left(Application.StatusBar, 6)) + 1) & "     FILES DONE"
    DoEvents
    Next
ExcelFile.Quit
WordFile.Quit
PowerPointFile.Quit

End Sub