Sub ScrubMetaData() 







     '
     ' ScrubMetaData Macro
     '
    Application.FileDialog(msoFileDialogOpen).Filters.Add _ 
    Description:="Word documents (*.doc; *.docx)", _ 
    Extensions:="*.doc;*.docx" 
 
    Dim wdd As Document 
    Dim intRetVal As Integer 
    Dim n As Integer 
 
    On Error Goto ErrHnd 
 
     'turn off screen updating so we don't see
     'all the documents opened and closed again
    Application.ScreenUpdating = False 
 
     'set the file open dialog filters
    Application.FileDialog(msoFileDialogOpen).Filters.Clear 
    Application.FileDialog(msoFileDialogOpen).Filters.Add _ 
    Description:="Word documents (*.doc; *.docx)", _ 
    Extensions:="*.doc;*.docx" 
 
     'setup and show the Open dialog box
    With Application.FileDialog(msoFileDialogOpen) 
        .Title = "Select Documents to Clean" 
         'set start folder
        .InitialFileName = "C:\temp\" 
        .AllowMultiSelect = True 
         'show the dialog box and get the button that was clicked
        intRetVal = .Show 
         'check that user selected Open (-1) rather than Cancel (0)
        If intRetVal = -1 Then 
             'iterate through the selected documents
            For n = 1 To .SelectedItems.Count 
                 'open document
                Set wdd = Documents.Open(.SelectedItems(n)) 
                 'clear personal data from document
                wdd.RemoveDocumentInformation (wdRDIAll) 
                 'save and close document
                wdd.Close SaveChanges:=True 
            Next n 
        End If 
    End With 
     'turn on screen updating
    Application.ScreenUpdating = True 
    Exit Sub 
 
     'error handler
ErrHnd: 
    Err.Clear 
     'turn on screen updating
    Application.ScreenUpdating = True 
End Sub

Sub ScrubMetadataExcel() 
     'Macro for cleaning personal data from files within selected folder.
    Dim objFS As Object, objFolder As Object 
    Dim objFiles As Object, objF1 As Object 
    Dim WordFile As Object 
    Dim PowerPointFile As Object 
    Dim FolderPath As FileDialog 
    Dim FolderName As String 
    Dim DocType As String 
    Dim CurrentFile As String 
    Set WordFile = CreateObject("Word.Application") 
    Set PowerPointFile = CreateObject("PowerPoint.Application") 
     ''''''''''''''''''''''''''''''''''''''''''''''
    Set FolderPath = Application.FileDialog(msoFileDialogFolderPicker) 
    With FolderPath 
        .AllowMultiSelect = False 
        .Show 
        FolderName = .SelectedItems(1) 
    End With 
     ''''''''''''''''''''''''''''''''''''''''''''''
    Set objFS = CreateObject("Scripting.FileSystemObject") 
    Set objFolder = objFS.GetFolder(FolderName) 
    Set objFiles = objFolder.Files 
    For Each objF1 In objFiles 
        CurrentFile = objF1.Path 
        Select Case Right(objF1.Name, 4) 
        Case ".xls", "xlsx", "xlsm" ': DocType = "xlRDIAll"
            Workbooks.Open (CurrentFile) 
            With ActiveWorkbook 
                .RemoveDocumentInformation (xlRDIAll) 
                .Save 
                .Close 
            End With 
        Case ".doc", "docx", "docm" ': DocType = "wdRDIAll"
            WordFile.documents.Open (CurrentFile) 
            With WordFile.ActiveDocument 
                .RemoveDocumentInformation (wdRDIAll) 
                .ActiveDocument.Save 
                .ActiveDocument.Close 
            End With 
        Case ".ppt", "pptx", "pptm" ': DocType = "ppRDIAll"
            PowerPointFile.Visible = True 
            PowerPointFile.Presentations.Open (CurrentFile) 
            With PowerPointFile.ActivePresentation 
                .RemoveDocumentInformation (ppRDIAll) 
                .Save 
                .Close 
            End With 
        End Select 
    Next 
    Set objF1 = Nothing: Set objFiles = Nothing: Set objFolder = Nothing: Set objFS = Nothing 
    ExcelFile.Quit 
    WordFile.Quit 
    PowerPointFile.Quit 
End Sub