#1
|
|||
|
|||
Word Macro to remove Metadata to include Excel and Powerpoint files.
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 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 Thanks for any help, I appreciate it. Last edited by macropod; 07-10-2014 at 01:10 AM. Reason: Added code tags & formatting |
#2
|
|||
|
|||
working code
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
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 Last edited by ShumaDK; 04-04-2018 at 03:59 AM. |
#3
|
|||
|
|||
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 |
Tags |
macro, metadata |
|
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 |