Microsoft Office Forums - View Single Post - [Solved] Word Macro to remove Metadata to include Excel and Powerpoint files.

ShumaDK · 04-03-2018, 04:25 AM

Here is the clear working code:

Code:

Sub ScrubMetadataExcel()

' Macro for cleaning personal data from files within selected folder.
' https://msdn.microsoft.com/en-us/vba/word-vba/articles/wdremovedocinfotype-enumeration-word

Dim objFS As Object
Dim objFolder As Object
Dim objFiles As Object
Dim 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 ExcelFile = CreateObject("Excel.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
Select Case Right(objF1.Name, 4)
    Case ".xls", "xlsx", "xlsm" ': DocType = "xlRDIAll"
        ExcelFile.Workbooks.Open (objF1.Path)
        With ExcelFile.ActiveWorkbook
            .RemoveDocumentInformation (99)
            .Save
            .Close
        End With
    Case ".doc", "docx", "docm" ': DocType = "wdRDIAll"
        WordFile.documents.Open (objF1.Path)
        With WordFile.ActiveDocument
            .RemoveDocumentInformation (99)
            .Save
            .Close
        End With
    Case ".ppt", "pptx", "pptm" ': DocType = "ppRDIAll"
        PowerPointFile.Visible = True
        PowerPointFile.Presentations.Open (objF1.Path)
        With PowerPointFile.ActivePresentation
            .RemoveDocumentInformation (99)
            .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

Some tips:

To open Developer Tab in Excel press Alt+F11.
If you get message "Be careful! Parts of your document may include personal information that can't be removed by the Document Inspector." you may supress it by unchecking the box "Remove personal information from file properties on save" under "Options > Trust Center > Trust Center Settings > Privacy Options". answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-mso_winother-mso_2013_release/be-careful-parts-of-your-document-may-include/fae98705-d078-4fc5-843a-908dda5be559
A list of available metadata attributes to clear and their values: msdn.microsoft.com/en-us/vba/word-vba/articles/wdremovedocinfotype-enumeration-word

Here is an improved (my final version) code with folder recursive (the idea taken here stackoverflow.com/questions/22645347/loop-through-all-subfolders-using-vba):

Code:

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")
DoFolder FileSystem.GetFolder(FolderName)
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
    Next

ExcelFile.Quit
WordFile.Quit
PowerPointFile.Quit

End Sub