VBA : Remove know password from multiple documents (improve code)

user_15506097 0
Viewed 849

Our company Logo has been changed. and we have over 5000 templates (.doc, .docx, .dotx, .xlsx, etc) Some of the documents are pw protected, others do not.

A ex-colleague before me created these (the person is not active in the company anymore)

So, I've have "created" a VBA code that semi works. This section is the same for all 3 macros. (only the Call changes)

Sub RemovePassword()
Dim strPath As String
Dim strFile As String
Dim doc As Document
On Error GoTo ErrHandler
     
    'Batch process to go through all files in a selected folder
     
     With Application.FileDialog(msoFileDialogFolderPicker)
         .Title = "Select a folder with Word documents"
         If .Show = False Then
             MsgBox "You didn't select a folder.", vbInformation
             Exit Sub
         End If
         strPath = .SelectedItems(1)
     End With
     If Right(strPath, 1) <> "\" Then
         strPath = strPath & "\"
     End If
     Application.ScreenUpdating = False
     strFile = Dir(strPath & "*.doc")
     Do While strFile <> ""
         Set doc = Documents.Open(strPath & strFile)
         
         'Call Macro (code) to process (replace only the name)
         Call RemovePwd
                  
         strFile = Dir
         doc.Save
         doc.Close
     Loop
     Exit Sub
ErrHandler:
          MsgBox Err.Description, vbExclamation
             
 End Sub

Sub RemovePwd()

    'Remove existing Pwd
    ActiveDocument.Unprotect Password:="Password" *'not the real pw'*
        
End Sub

This one removes the password of the .doc documents in a selected folder (code works) I have 2 issues with this code.

  1. When a document is not password protected this macro skips all documents in the selected folder. So, the documents remain locked. I have to find all the not protected ones manually remove them out of the folder or add the protection to them as well.

can the code be adjusted so when a document has no password it skips that document and continues to the next?

  1. can the code be adjusted that this happens for all extension for Word and/or Excel.

The other 2 macro's

Removing the old Logo

Sub RemoveOldLogo()
Dim hdr As HeaderFooter
Dim sec As Section
Dim sh As Shape
    
    'Loop through all existing headers in document
    For Each sec In ActiveDocument.Sections
    
        For Each hdr In sec.Headers
        
            Set rng = hdr.Range
            
            For Each sh In hdr.Shapes
            
                'Delete found Logo
                sh.Delete
                
            Next sh
            
        Next hdr
        
    Next sec
    
End Sub

Adding the new logo

Sub AddNewLogo()


    'Copy Logo from Master template
    ChangeFileOpenDirectory "C:\MASTER_TEMPLATE\"
    Documents.Open FileName:= _
        "C:\MASTER_TEMPLATE\MASTER_Logo.doc", _
        ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
        PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
        WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
        wdOpenFormatAuto, XMLTransform:=""
    ActiveWindow.ActivePane.View.SeekView = wdSeekFirstPageHeader
    Selection.WholeStory
    Selection.Copy
    ActiveWindow.Close
    
    'Paste Logo
    ActiveWindow.ActivePane.View.SeekView = wdSeekFirstPageHeader
    Selection.PasteAndFormat (wdFormatOriginalFormatting)

End Sub

All these macros combined to run with the following macro

Sub RunAllMacros()
        RemovePassword
        RemoveOldLogo
        AddNewLogo
End Sub

Like I said these code work with the exception of when 1 document in a folder is not pw protected, it doesn't removed it from the other documents in that folder that do have a pw.

If someone has a better solution on how to do this that info is welcome too!

I'm not very experience with VBA and such, this is all found online, adjusted and combined from different code.

Thanks

Kr, Thierry

password-protection ms-word vba
2 Answers

The main problem you have it that Word throws a runtime error if you try to unprotect a document that has no protection. Additionally, I would suggest you remove the On Error GoTo ErrHandler-statement (as it's better to let the VBA runtime to show you the exact statement where an error occurred).

Do a simple change in your unprotect routine: Check first if the doc has a protection. I would suggest that you pass the doc as parameter so you don't rely on ActiveDocument (you need to change the call to Call RemovePwd(doc) (or simply RemovePwd doc which means exactly the same)

Sub RemovePwd(doc as Document)
    If doc.ProtectionType <> wdNoProtection Then 
    'Remove existing Pwd
        doc.Unprotect Password:="Password" *'not the real pw'*
    End If
End Sub

For Excel, by the way, this check is not needed, you can issue unprotect for an unprotected workbook without run time error.

To fetch all Word docs, change the Dir-command to

strFile = Dir(strPath & "*.do*")

This should find all doc, docx, docm, dotx ...

user_75997980

It looks as though you are looping through the set of files multiple times. It would be much more efficient to only do that once.

You can also replace the headers in a single operation without needing to delete the headers first. Your code actually deletes all three types of header in each section of the document but only replaces a single header in a single section. The updated code below only replaces a single header. You'll need to check whether your documents contain multiple headers and edit the code accordingly.

You can make your error handling more informative if you add line numbers to your code. Then you can use Erl to report which line the error occured on.

Sub ChangeDocumentHeaders()
         Dim strPath As String
         Dim strFile As String
         Dim doc As Document
         Dim masterLogo As Document
10       On Error GoTo ErrHandler
           
         'Batch process to go through all files in a selected folder
           
20       With Application.FileDialog(msoFileDialogFolderPicker)
30          .Title = "Select a folder with Word documents"
40          If .Show = False Then
50             MsgBox "You didn't select a folder.", vbInformation
60             Exit Sub
70          End If
80          strPath = .SelectedItems(1)
90       End With
100      If Right(strPath, 1) <> "\" Then
110         strPath = strPath & "\"
120      End If
130      Set masterLogo = Documents.Open("C:\MASTER_TEMPLATE\MASTER_Logo.doc")
140      Application.ScreenUpdating = False
150      strFile = Dir(strPath & "*.do*")
160      Do While strFile <> ""
170         Set doc = Documents.Open(strPath & strFile)
               
            'Call Macro (code) to process (replace only the name)
180         RemovePassword doc
190         ReplaceHeader doc, masterLogo
                        
200         strFile = Dir
210         doc.Save
220         doc.Close
230      Loop
240      masterLogo.Close
250      Exit Sub
ErrHandler:
260      MsgBox "Error on line: " & Erl & vbCr & Err.Description, vbExclamation
                   
End Sub

Sub ReplaceHeader(Target As Document, Source As Document)
   Dim NewHeader As Range
   
   Set NewHeader = Source.Sections(1).Headers(wdHeaderFooterPrimary).Range
   
   With Target.Sections(1).Headers(wdHeaderFooterPrimary).Range
      .FormattedText = NewHeader.FormattedText
      'replacing header may leave an extra empty paragraph, so remove it
      With .Paragraphs.Last.Range
         If Len(.Text) = 1 Then .Delete
      End With
   End With
   
End Sub

Sub RemovePassword(doc As Document)
    If doc.ProtectionType <> wdNoProtection Then
    'Remove existing Pwd
        doc.Unprotect Password:="Password"
    End If
End Sub
user_52117520
Related