Word Macro to remove Metadata to include Excel and Powerpoint files.

Dan_M · #1 07-09-2014, 01:18 PM

Hi,
I placed theis request in Word Macor because that is where I started i guess. The following macro works perfectly for Word 2010.

Code:

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

I am trying To include Excel files And Powerpoint files.
Basically 1 macro To copy into Word, Excel And Powerpoint.
Having alot of trouble.

I had some help With the following redone code, but only Excel works -

Code:

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

- Banging my head against the wall -
Thanks for any help, I appreciate it.

ShumaDK · #2 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

ShumaDK · #3 04-04-2018, 05:09 AM

Added counter in the status bar.

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")
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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Can a macro rename Excel files based on a cellname?	chrisd2000	Excel Programming	1	06-23-2014 06:50 PM
Mail merge from Excel to Word and include hyperlinks	chay	Mail Merge	5	09-28-2013 01:16 AM
Opening Word /Excel reinstalls files, loses recent files	adj1	Office	3	05-10-2013 12:27 AM
Can excel Replace metadata of image files?	quiff	Excel	0	11-23-2011 12:39 AM
Merging word files from excel macro	hklein	Excel Programming	0	08-05-2011 02:27 AM