Code to Password protect all files in a dir.

L

levanoj

Active Member
Joined
Oct 25, 2007
Messages
311
The following code is what I have at this time to password protect an individual file when it is open.
When I run it it simply pops up a screen asking me to enter the password I want to protect the file with, I enter the file then click ok.
Code: 
Sub Protect_sheets()
    Dim wSheet          As Worksheet
    Dim Pwd             As String
 
    Pwd = InputBox("Enter your password to protect all worksheets", "Password Input")
    For Each wSheet In Worksheets
        wSheet.Protect Password:=Pwd
    Next wSheet
 
End Sub

What I'm looking for is a a code that instead when run I want to 1st prompt me to select a directory and once selected have a 2nd prompt asking me to enter the password of my choice then lastly open each file within the chosen directory, protect it using the password just entered and saved. Can anyone assist?
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Sort by date Sort by votes
Try this:
Code: 
Option Explicit

Sub PasswordProtectAllFilesInFolder()
'JBeaucaire    3/4/2010
'Select a folder and provide password to protect all Excel files in folder
Dim fPath As String, fName As String, OldDir As String
Dim pwd As String, pwd2 As String, ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

'Folder selection
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then fPath = .SelectedItems(1) & "\"
    End With
    
'Password w/verification
    Do
        pwd = Application.InputBox("What password to use?", "Enter Password", Type:=2)
        If pwd = "False" Then Exit Sub
        pwd2 = Application.InputBox("Please enter the password again for verification?", "Re-Enter Password", Type:=2)
        If pwd2 = "False" Then Exit Sub
        If pwd = pwd2 Then
            Exit Do
        Else
            MsgBox "Passwords did not match, please try again"
        End If
    Loop

    OldDir = CurDir
    ChDir fPath
    fName = Dir("*.xls")

'File protection    
    Do While Len(fName) > 0
        Workbooks.Open fName
            For Each ws In ActiveWorkbook.Worksheets
                ws.Protect Password:=pwd
            Next ws
        ActiveWorkbook.Close True
    Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
 
Upvote 0
Hey jbeaucaire,
I tried the code and although I do get prompted to choose a directory and then asked to enter a password, once I re-enter the password and click OK all that happens is the hour glass pops up and the Excel tab pops up over and over on the bottom of the screen as if it were opening and closing a whole bunch of excel files. The problem though is the folder I chose only has 3 excel files in it. Any thoughts?
 
Upvote 0
Oops!

Add this one missing line of code:
Rich (BB code): 
        ActiveWorkbook.Close True
        fName = Dir
    Loop

My bad....without that it was just opening the first file over and over again forever.
 
Last edited:
Upvote 0
Just so no one has to "piece together" all the snippets above to get a fully working macro, here's the whole thing:
Code: 
Sub PasswordProtectAllFilesInFolder()
'JBeaucaire    3/4/2010
'Select a folder and provide password to protect all Excel files in folder
Dim fPath As String, fName As String, OldDir As String
Dim pwd As String, pwd2 As String, ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then fPath = .SelectedItems(1) & "\"
    End With
    
    Do
        pwd = Application.InputBox("What password to use?", "Enter Password", Type:=2)
        If pwd = "False" Then Exit Sub
        pwd2 = Application.InputBox("Please enter the password again for verification?", "Re-Enter Password", Type:=2)
        If pwd2 = "False" Then Exit Sub
        If pwd = pwd2 Then
            Exit Do
        Else
            MsgBox "Passwords did not match, please try again"
        End If
    Loop
    
    OldDir = CurDir
    ChDir fPath
    fName = Dir("*.xls")
    
    Do While Len(fName) > 0
        Workbooks.Open fName
            For Each ws In ActiveWorkbook.Worksheets
                ws.Protect Password:=pwd
            Next ws
        ActiveWorkbook.Close True
        fName = Dir
    Loop

ChDir OldDir
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
 
Upvote 0
And now, since I am going to be using this myself...I've expanded it to allow you to CHOOSE whether you are protecting or unprotecting the files in the folder, so the one macro can do both jobs.

Code: 
Option Explicit

Sub SetProtectionInAllSheetsAllFilesInFolder()
'JBeaucaire    3/4/2010
'Select a folder and provide password to protect all Excel files in folder
Dim fPath As String, fName As String, OldDir As String
Dim pwd As String, pwd2 As String, ws As Worksheet
Dim Ans As Long, Cnt As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

'Folder selection
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then fPath = .SelectedItems(1) & "\"
    End With
    
'Choose whether to protect or unprotect the files
    Ans = Application.InputBox("Are we protecting or unprotecting the files in this folder?" & vbLf & vbLf & _
        "Enter 1 - protect files" & vbLf & "Enter 2 - unprotect files" & vbLf & vbLf & _
        "Any other value or CANCEL will abort", "Protect or Unprotect?", Type:=1)
    If Ans < 1 Or Ans > 2 Then Exit Sub
    
'Password w/verification
    Do
        pwd = Application.InputBox("What password to use?", "Enter Password", Type:=2)
        If pwd = "False" Then Exit Sub
        pwd2 = Application.InputBox("Please enter the password again for verification?", "Re-Enter Password", Type:=2)
        If pwd2 = "False" Then Exit Sub
        If pwd = pwd2 Then
            Exit Do
        Else
            MsgBox "Passwords did not match, please try again"
        End If
    Loop

    OldDir = CurDir
    ChDir fPath
    fName = Dir("*.xls")

'File protection
    Do While Len(fName) > 0
        Workbooks.Open fName
            For Each ws In ActiveWorkbook.Worksheets
                If Ans = 1 Then ws.Protect Password:=pwd Else ws.Unprotect Password:=pwd
            Next ws
        ActiveWorkbook.Close True
        fName = Dir
        Cnt = Cnt + 1
    Loop

ChDir OldDir
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
MsgBox "A total of " & Cnt & " files were processed."
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

Pinaceous
  • Question
VBA Protect Sheet
Replies
1
Views
682
eiloken
E
R
  • Solved
Hide / Unhide Rows in protected sheets
Replies
1
Views
1K
rlv01
R
R
  • Question
Array Worksheets
Replies
1
Views
270
Peter_SSs
Peter_SSs
G
  • Question
ListObjectsTable_Protection except one column
Replies
1
Views
228
GUNI
G
G
  • Solved
VBA to allow grouping +- after reopening of the sheet
Replies
7
Views
750
Greenbehindthecells
G

Forum statistics

Threads
1,214,827
Messages
6,121,806
Members
449,048
Latest member
greyangel23

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top