Global Password Change

[Guest]

We have a number of worksheets containing sensitive data that are protected
by password. Periodically, the firm's principal requests that we change the
password for each. As there are a relatively large number of sheets to
change, is there a means by which we could update the password for all sheets
in a folder & its subfolders?

Thank you.
Sprinks

 

[Zone]

Sprinks, are you saying you want to change the passwords of all the
worksheets in all the workbooks in a folder and its subfolder? How
complicated this will be depends on 1. Do all the worksheets in each
workbook have the same password? 2. Do all the worksheets in ALL the
workbooks have the same password? James

 

[Guest]

Zone,

Thank you for your response. I’m glad you asked the question, because our
requirements are somewhat more complex than I originally thought. The
current situation is:

• Some workbooks have a password but their worksheets do not.
• Some workbooks have a password and passwords on their sheets as well.
• The passwords are currently not all the same due to poor management by
their previous owner. There is no need for them to be different, nor is
there a need to have a password for any worksheets. One on the workbook
itself is sufficient.
• Some workbooks in the current folder do not have a password.
• The VBA solution should:
o request the folder to operate upon
o request the current password from the user
o change the password of all workbooks in the folder and its
subfolders where the currently assigned password matches the one entered or
is blank
o remove the password from all worksheets

The user could initially run the code multiple times for the 2 or 3
passwords currently in use.

The user has asked for one additional requirement. Since she uses dozens,
even hundreds of workbooks a day, she is asking if in lieu of logging into
each workbook with the same identical password, she could log in once into a
“master†workbook.

As long as this workbook is open, it would provide the password needed to
open the second workbook, providing in essence a “password by sessionâ€. When
she leaves her desk, she will log out of the master workbook to prevent
others from loading any of the protected workbooks.

Thanks for your help.
Sprinks

 

[NickHK]

What you are after is certianly doable, but you need to break it down into
steps.

0. Ask the user for the new PW to use on all WBs.

1. Open/list files in a folder and subfolders:
See Bob's answer to "Recursive procedure" in this NG from 18/10.

2. Provide an InputBox to accept the user's input of the WB Password.

3. Using PW to attempt to open the first WBs from #1. Trap the error on
failure and optionally record the WB's name.

4. Check for protection on the WSs in the newly opened WB, asking the user
for PW input if necessary. Unprotect each.

5. Protect the WB with the PW from #0

6. Save/Close the WB

7. Loop to #3, until all WBs from #1 are processed.

As for the "session" password, maybe you need application level events, with
an InputBox routine in Personal.xls to request PW upon opening:
http://www.cpearson.com/excel/AppEvent.htm

NickHK

 

[Zone]

Sprinks, I agree with Nick. If you break this project down into
individual steps, you can focus on each step in turn. And if you get
stuck on a step, you can post a question on that step. James

 

[Guest]

Nick and James,

Thank you for your help. I agree--Divide and Conquer.

Unfortunately, although I'm an experienced Access programmer, I don't have
much background in Excel. My attempt at the first step, getting the folder
name, displays the dialog box, but what is selected does not transfer to the
Folder Name: input box.

Am I missing something? I'm using Excel 2003 (11.8033.8036) SP2.

Thank you.
Sprinks

Sub ResetPasswords()
On Error Resume Next

Dim fd As FileDialog

' Request folder name
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Show

End Sub

 

[Zone]

Sprinks, if you're working in Excel VBA, something like this might be
better.

Sub OpenWkbk()
Dim myWkbk As String
ChDir "c:\myFolder"
myWkbk = Application.GetOpenFilename()
MsgBox myWkbk
End Sub

Assuming you replace "c:\myFolder" with the path that contains the
subfolders you want to work with, this will show you the subfolders in
that path. Then you will have the GetOpenFilename dialog
functionality, which means you can double-click on a subfolder to open
it, then select an individual file to open and get its path. HTH,
James

 

[Guest]

Zone,

Thanks for your help.

Sprinks

Sprinks, if you're working in Excel VBA, something like this might be
better.

Sub OpenWkbk()
Dim myWkbk As String
ChDir "c:\myFolder"
myWkbk = Application.GetOpenFilename()
MsgBox myWkbk
End Sub

Assuming you replace "c:\myFolder" with the path that contains the
subfolders you want to work with, this will show you the subfolders in
that path. Then you will have the GetOpenFilename dialog
functionality, which means you can double-click on a subfolder to open
it, then select an individual file to open and get its path. HTH,
James

 

[Guest]

Nick and Zone,

Thanks to your help, I was able to get this to work. The solution uses a
password-protected workbook that starts from the Office Manager's XLStart
folder. The top-level sheet, "Macros", displays a list of two macros,
ResetPasswords, and LoadFile.

The first uses a Userform to get the old and new passwords (confirming
each), and the folder location, which has a default value but can be changed
with a command button. The user can also choose whether to change blank
passwords to the new value or leave it blank.

The code attached to the OK button writes the new password to the
password-protected sheet so that its value is available to the LoadFile
macro, which supplies the password to any file she wishes to open, then loops
through all the files in the chosen folder and subfolder, changing the
password as appropriate, and writing all files to a section of the worksheet,
with the action taken for each.

Thanks again for your help.

Sprinks

Private Sub cmdOK_Click()
' Requires:
' - Function GetFolderName
On Error GoTo ErrHandler

' Declare Constants
' This sub writes filenames and results to a cell block.
' Currently it will start at F6:G6.
Const cintRow As Integer = 6 ' Row 6
Const cintCol As Integer = 6 ' Column F

' Declare variables.
Dim fs As FileSearch
Dim wb As Workbook
Dim astrParsedName() As String
Dim i As Integer
Dim strMsg As String
Dim strOld, strNew As String
Dim strFileName As String
Dim strResponse As String
Dim blnChangeBlank As Boolean
Dim astrResult(1 To 3) As String

'Validate form data
If Me![txtOPW] = "" Then
MsgBox "No value entered for the old password.", , "Invalid Data"
Me![txtOPWV] = ""
Me![txtOPW].SetFocus
GoTo ErrExit
End If

If Me![txtOPW] <> Me![txtOPWV] Then
MsgBox "Old passwords do not match.", , "Invalid Data"
Me![txtOPWV] = ""
With Me!txtOPW
.Value = ""
.SetFocus
End With
GoTo ErrExit
End If

If (IsNull(Me![txtNPW]) Or Me![txtNPW] = "") Then
strNew = ""
strResponse = MsgBox("No value entered for the new password. Press
" & _
"OK to remove all passwords or Cancel to exit.", _
vbOKCancel + vbDefaultButton2 + vbCritical,
"Remove All Passwords?")
If strResponse = vbCancel Then
Me![txtNPWV] = ""
Me![txtNPW].SetFocus
GoTo ErrExit
End If
Else: strNew = Me![txtNPW]
End If

If Me![txtNPW] <> Me![txtNPWV] Then
MsgBox "New passwords do not match.", , "Invalid Data"
Me![txtNPWV] = ""
With Me![txtNPW]
.Value = ""
.SetFocus
End With
GoTo ErrExit
End If

' Form data is OK, initialize variables
astrResult(1) = "PW Changed"
astrResult(2) = "PW Blank"
astrResult(3) = "Couldn't Open"
strOld = Me![txtOPW]
' strNew Initialized above
blnChangeBlank = Me![chkBlank]

Application.EnableEvents = False

' Initialize filesearch object.
Set fs = Application.FileSearch

' Set folder to search, subfolders, and filter
With fs
.LookIn = Me![txtFolderName]
.Filename = "*.xls"
.SearchSubFolders = True
End With

If fs.LookIn = "" Then
GoTo ErrExit
End If

' Execute the file search, and check to see if the file(s) are present.
If fs.Execute() > 0 Then

' Write new password to sheet, Cell B50
Me.Hide
ActiveWorkbook.Worksheets("Splash").Activate
With ActiveWorkbook.Worksheets("Macros")
.Unprotect Password:=strOld
.Cells(50, 2).Value = strNew
End With

' Set new password for AdminMacros workbook
With ActiveWorkbook
.Password = strNew
.Worksheets("Macros").Protect Password:=strNew
.Worksheets("Splash").Visible = True
End With

' Turn off screen updating while opening files
Application.ScreenUpdating = False

' Write headings to worksheet
Workbooks("AdminMacros.xls").Sheets("Macros").Cells(cintRow - 1, _
cintCol).Value = "Target Files"
Workbooks("AdminMacros.xls").Sheets("Macros").Cells(cintRow - 1, _
cintCol + 1).Value = "Result"

' Write all filenames to worksheet
For i = 1 To fs.FoundFiles.Count
' Get filename without path; write to worksheet
astrParsedName = Split(fs.FoundFiles.Item(i), "\")
strFileName = astrParsedName(UBound(astrParsedName))
Workbooks("AdminMacros.xls").Sheets("Macros").Cells(cintRow + i
- 1, _
cintCol).Value = strFileName
Next i

' Attempt to open workbook with the supplied password.
' If successful, the password could either match or be blank.
' If the workbook has a password or if user selected blank files,
' reset the password to the new value.
For i = 1 To fs.FoundFiles.Count
On Error Resume Next
Set wb = Nothing
Set wb = Workbooks.Open _
(Filename:=fs.FoundFiles.Item(i), Password:=strOld)

On Error GoTo ErrHandler
If wb Is Nothing Then
' File has a different password, write status to worksheet
Workbooks("AdminMacros.xls").Sheets("Macros").Cells(cintRow
+ i - 1, _
cintCol + 1).Value = astrResult(3)
Else
With ActiveWorkbook
If (.HasPassword Or blnChangeBlank = True) Then

Workbooks("AdminMacros.xls").Sheets("Macros").Cells(cintRow + i - 1, _
cintCol + 1).Value = astrResult(1)
.Password = strNew
.Save
Else
' Password was blank and user doesn't want to change
it

Workbooks("AdminMacros.xls").Sheets("Macros").Cells(cintRow + i - 1, _
cintCol + 1).Value = astrResult(2)
End If
.Close
End With
End If
Next i

Unload Me
With ActiveWorkbook
.Worksheets(1).Activate
.Worksheets("Splash").Visible = False
.Save
End With

Else
' Display message if no files were found.
MsgBox "No files were found in: " & vbCrLf & vbCrLf _
& fs.LookIn, vbOKOnly, "No Files Found!"
End If

ErrExit:
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set fs = Nothing
Set wb = Nothing
Exit Sub

SubExit:
Set fs = Nothing
Application.EnableEvents = True

ErrHandler:
MsgBox "There has been the following error. Please contact the macro "
& _
"administrator." & _
vbCrLf & vbCrLf & Err.Number & vbCrLf & " " & Err.Description
Resume ErrExit


End Sub