Convert all excel files in a folder to have password to modify option

[bh24524]

Hello, I was asked by a co-worker to see if there is a code he can use to make all excel files in a specific folder require a password to modify. He wanted to start using this option going forward when he saves his files, but he wants to do the same thing with the rest of the files in the folder. There are many people viewing the file but they should all only be read-only and only he should be able to make edits. To clarify, I am not meaning the Protect Workbook option, I am talking about when you go to Save As, then the tools dropdown, and then general options where it gives you the password to open and password to modify options. He wants to use the same password so we'll just say the password is "password" and I can edit the code to have it changed to what he truly wants it to be. We'll just say that the folder containing the files is in the C Drive called "Sample". Is there a code that can accomplish this? Thank you!

 

[PeteWright]

Hi @bh24524 !

I've been struggling a bit while trying to find a solution and I'm not yet fully satisfied with the result, but nevertheless, here is a code snippet I've made up:

Public Sub pwd()
   Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
   Dim fol As Folder
   Dim fil As File
   Dim diaFolder As FileDialog
   Dim fStr As String
   Dim wb As Workbook
   Dim pw As String
   Dim pw2 As String
   
   Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
   diaFolder.AllowMultiSelect = False
      
   If diaFolder.Show = 0 Then
      Exit Sub
   End If
      
   fStr = diaFolder.SelectedItems(1)
   Set fol = fso.getFolder(fStr)
pw_in:
   pw = InputBox("Please enter the Modifying Password", "Password", "")
   If (StrPtr(pw) = 0) Then Exit Sub
   pw2 = InputBox("Please confirm the Modifying Password", "Confirm Password", "")
   If (StrPtr(pw2) = 0) Then Exit Sub
   
   If (pw = "" Or pw2 = "") Then
      MsgBox "Empty Password detected. Please try again!"
      GoTo pw_in
   End If
   
   If (pw <> pw2) Then
      MsgBox "Passwords don't match! Please try again!"
      GoTo pw_in
   End If
   
   For Each fil In fol.files
      If (LCase(Right(fil.Name, 4)) = "xlsx" Or LCase(Right(fil.Name, 3)) = "xls") Then
         Set wb = Workbooks.Open(fil)
         wb.SaveAs Filename:=fil.ParentFolder & "\" & Left(fil.Name, InStrRev(fil.Name, ".") - 1) & "_protected" & Mid(fil.Name, InStrRev(fil.Name, ".")), WriteResPassword:=pw
         wb.Close
      End If
   Next
   Set diaFolder = Nothing
End Sub

And this is what the code does:

1. Select a working path / folder
2. User input: Enter and confirm a password for modifying the workbook
3. Open each file in the folder
4. Check if the file is an Excel Workbook with correct file extension (*.xlsx or *.xls)
5. If true, save the file with a filename suffix (_protected) and a previously defined password for editing

Now the problem(s):

If the currently processed workbook already has a modifying password and the user presses the [Cancel] or [X] Button the whole process will stop and end up in an error message (Error 1004).
I've tried to handle this particular error with "On Error Resume Next" or "If Err.Number = 1004 Then" but none of the error catching worked.
Unfortunately Excel VBA doesn't provide a "try ... catch ..." method for error handling.

So at this point I'm stumped and maybe someone else has an idea how to handle this error.

Anyway, I hope I could help a little so please let me know if you have any further questions or suggestions.

 

[bh24524]

Thank you very much! I'm going to try this when I get back to the office on Monday. Just a question though, I don't want to have a password to open, just to edit so basically if they don't have the password, they'd just click the read-only button. Would that change this code any? Thankfully, none of the files currently require a password, so this sounds promising!

 

[PeteWright]

Thank you very much! I'm going to try this when I get back to the office on Monday. Just a question though, I don't want to have a password to open, just to edit so basically if they don't have the password, they'd just click the read-only button. Would that change this code any? Thankfully, none of the files currently require a password, so this sounds promising!

The property WriteResPassword only sets a "modifying password" so the code was made for that purpose.

If you do have Excel at home you can try the VBA code with a blank workbook so no need to play with your company files (anyway, the original file stays untouched, there will only be a copy).

 

[bh24524]

Alright I got a chance to run this at work since I couldn't at home and it did work after I enabled the Microsoft Scripting Run-time from the references menu. It asked me to select the folder and then it made copies separate from the originals. Great to know that it works. If you can though modify it to over-write the existing files, that would be great. Thinking further on it, I do like that you can select the folder path as opposed to having a specified one in the code, so Good thinking on that. I can see him wanting to do this for multiple folders since it's the same file spanning multiple years and each year having its own folder, so we can leave that portion alone. So really just the alteration to over-write the files and not make copies and I think we're good to go!

 

[bh24524]

So I experimented with it and removed the & "_protected" sequence from the code and I added the Application.DisplayAlerts = False at the beginning of the code and then changed it back to True at the end and that allowed the existing files to be saved/overwritten:

Public Sub pwd()
   Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
   Dim fol As Folder
   Dim fil As File
   Dim diaFolder As FileDialog
   Dim fStr As String
   Dim wb As Workbook
   Dim pw As String
   Dim pw2 As String
   Application.DisplayAlerts = False
 
   Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
   diaFolder.AllowMultiSelect = False
    
   If diaFolder.Show = 0 Then
      Exit Sub
   End If
    
   fStr = diaFolder.SelectedItems(1)
   Set fol = fso.getFolder(fStr)
pw_in:
   pw = InputBox("Please enter the Modifying Password", "Password", "")
   If (StrPtr(pw) = 0) Then Exit Sub
   pw2 = InputBox("Please confirm the Modifying Password", "Confirm Password", "")
   If (StrPtr(pw2) = 0) Then Exit Sub
 
   If (pw = "" Or pw2 = "") Then
      MsgBox "Empty Password detected. Please try again!"
      GoTo pw_in
   End If
 
   If (pw <> pw2) Then
      MsgBox "Passwords don't match! Please try again!"
      GoTo pw_in
   End If
 
   For Each fil In fol.Files
      If (LCase(Right(fil.Name, 4)) = "xlsx" Or LCase(Right(fil.Name, 3)) = "xls") Then
         Set wb = Workbooks.Open(fil)
         wb.SaveAs Filename:=fil.ParentFolder & "\" & Left(fil.Name, InStrRev(fil.Name, ".") - 1) & Mid(fil.Name, InStrRev(fil.Name, ".")), WriteResPassword:=pw
         wb.Close
      End If
   Next
   Set diaFolder = Nothing
   Application.DisplayAlerts = True
End Sub

So it works and I think we are good then, so thank you again for your help in this - it is a great solution!

 

[PeteWright]

Glad I could help a little and you figured it out by yourself in the end

Just let us know if you need any further assistance.