Microsoft Office Forums

Go Back   Microsoft Office Forums > Microsoft Word > Word VBA

Reply
 
LinkBack Thread Tools Display Modes
  #1  
Old 07-09-2014, 01:18 PM
Dan_M Dan_M is offline Windows 7 32bit Office 2010 32bit
Novice
 
Join Date: Jul 2014
Posts: 1
Dan_M is on a distinguished road
Default 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
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.

Last edited by macropod; 07-10-2014 at 01:10 AM. Reason: Added code tags & formatting
Reply With Quote
Reply

Tags
macro, metadata

Thread Tools
Display Modes


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


All times are GMT -7. The time now is 03:49 AM.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
SEO by vBSEO ©2011, Crawlability, Inc.
MSOfficeForums.com is not affiliated with Microsoft