S
Sprinks
After getting a macro to work which reset the passwords for each file in a
user-selected folder and its subfolder, I decided this would be a good
application for using my first Userform.
My previous macro now just loads the userform, and I've moved the code to
buttons on the form. Before, the flow was linear--get the folder to operate
on, validate each piece of data as it was entered, and display a message and
exit if the criteria is not met.
In the new form, I've textboxes for the old and new passwords (2 each), a
default filefolder location, OK and Cancel buttons, and a button to change
the default folder location. The latter is working fine--it writes the user
selection to the textbox.
In the OK button procedure, I'm trying to pick up the textbox value as the
..LookIn property of the FileSearch object, but I'm getting the subject error
message. Can anyone point out where I'm erring?
Thank you for all assistance.
Sprinks
Private Sub cmdChangeFolder_Click()
On Error GoTo ErrHandler
' Dimension variables.
Dim fs As FileSearch
Application.EnableEvents = False
' Declare filesearch object.
Set fs = Application.FileSearch
' Set folder to search.
With fs
.SearchSubFolders = True
.LookIn = GetFolderName() ' See function below
End With
If fs.LookIn = "" Then
GoTo ErrExit
End If
' Set file name to search for.
fs.Filename = "*.xls"
' Execute the file search, and check to see if the file(s) are present.
If fs.Execute > 0 Then
With Me![txtFolderName]
.Locked = False
.Value = fs.LookIn
.Locked = True
End With
End If
ErrExit:
Application.EnableEvents = True
Set fs = Nothing
Exit Sub
ErrHandler:
MsgBox "There has been the following error. Please contact the macro "
& _
"administrator." & _
vbCrLf & vbCrLf & Err.Number & vbCrLf & " " & Err.Description
Resume ErrExit
End Sub
Private Sub cmdOK_Click()
' Requires:
' - Function GetFolderName
'On Error GoTo ErrHandler
' Dimension variables.
Dim fs As FileSearch
Dim wb As Workbook
Dim astrParsedName() As String
Dim astrCantOpen() As String
Dim i, j As Integer
Dim strMsg As String
Application.EnableEvents = False
' Declare filesearch object.
Set fs = Application.FileSearch
' Set folder to search, subfolders, and filter
With fs
.LookIn = Me![txtFolderName]
.SearchSubFolders = True
.Filename = ".xls"
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
'Validate data
If Me![txtOPW] <> Me![txtOPWV] Then
MsgBox "Old passwords do not match."
Me!txtOPWV = ""
With Me!txtOPW
.Value = ""
.SetFocus
End With
Exit Sub
End If
If Me!txtNPW <> Me!txtNPWV Then
Me!txtNPWV = ""
With Me!txtNPW
.Value = ""
.SetFocus
End With
Exit Sub
End If
' Write new password to sheet
ActiveWorkbook.Worksheets("Splash").Activate
With ActiveWorkbook.Worksheets("Macros")
.Unprotect
.Cells(50, 2).Value = Me!txtNPW
End With
With ActiveWorkbook
.Password = Me!txtNPW
.Worksheets("Macros").Protect
.Worksheets("Splash").Visible = True
End With
Application.ScreenUpdating = False
' Loop through all files
j = 0
For i = 1 To fs.FoundFiles.Count
Set wb = Nothing
On Error Resume Next
Set wb = Workbooks.Open _
(Filename:=fs.FoundFiles.Item(i), Password:=Me![txtOPW])
On Error GoTo 0
If wb Is Nothing Then
' File has a different password; write name to astrCantOpen
array
j = j + 1
astrParsedName = Split(fs.FoundFiles.Item(i), "\")
ReDim Preserve astrCantOpen(j)
astrCantOpen(j) = astrParsedName(UBound(astrParsedName))
Else
' If file has a password, change it to the new one
If ((ActiveWorkbook.HasPassword) Or Me![chkBlank]) Then
With ActiveWorkbook
.Password = Me![txtNPW]
.Save
End With
End If
ActiveWorkbook.Close
End If
Next i
On Error GoTo ErrHandler
If j <> 0 Then
' Some files couldn't be opened
strMsg = "Couldn't open files: " & vbCrLf & vbCrLf
For i = 1 To UBound(astrCantOpen)
strMsg = strMsg & astrCantOpen(i) & vbCrLf
Next i
strMsg = strMsg & vbCrLf & vbCrLf & "Other passwords set
successfully."
MsgBox strMsg
Else
MsgBox "Password change for all files in: " & vbCrLf & vbCrLf & _
fs.LookIn & vbCrLf & vbCrLf & _
" & its subfolders was successful.", vbOKOnly, "Password Reset
Successful!"
End If
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
ErrHandler:
MsgBox "There has been the following error. Please contact the macro "
& _
"administrator." & _
vbCrLf & vbCrLf & Err.Number & vbCrLf & " " & Err.Description
Resume ErrExit
End Sub
Function GetFolderName() As Variant
On Error GoTo ErrHandler
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
' Request folder name
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then
GetFolderName = fd.SelectedItems(1)
Else
' the user pressed Cancel
GetFolderName = ""
End If
' Clean up
Set fd = Nothing
ErrExit:
Exit Function
ErrHandler:
MsgBox "There has been the following error. Please contact the macro "
& _
"administrator." & _
vbCrLf & vbCrLf & Err.Number & vbCrLf & " " & Err.Description
Resume ErrExit
End Function
user-selected folder and its subfolder, I decided this would be a good
application for using my first Userform.
My previous macro now just loads the userform, and I've moved the code to
buttons on the form. Before, the flow was linear--get the folder to operate
on, validate each piece of data as it was entered, and display a message and
exit if the criteria is not met.
In the new form, I've textboxes for the old and new passwords (2 each), a
default filefolder location, OK and Cancel buttons, and a button to change
the default folder location. The latter is working fine--it writes the user
selection to the textbox.
In the OK button procedure, I'm trying to pick up the textbox value as the
..LookIn property of the FileSearch object, but I'm getting the subject error
message. Can anyone point out where I'm erring?
Thank you for all assistance.
Sprinks
Private Sub cmdChangeFolder_Click()
On Error GoTo ErrHandler
' Dimension variables.
Dim fs As FileSearch
Application.EnableEvents = False
' Declare filesearch object.
Set fs = Application.FileSearch
' Set folder to search.
With fs
.SearchSubFolders = True
.LookIn = GetFolderName() ' See function below
End With
If fs.LookIn = "" Then
GoTo ErrExit
End If
' Set file name to search for.
fs.Filename = "*.xls"
' Execute the file search, and check to see if the file(s) are present.
If fs.Execute > 0 Then
With Me![txtFolderName]
.Locked = False
.Value = fs.LookIn
.Locked = True
End With
End If
ErrExit:
Application.EnableEvents = True
Set fs = Nothing
Exit Sub
ErrHandler:
MsgBox "There has been the following error. Please contact the macro "
& _
"administrator." & _
vbCrLf & vbCrLf & Err.Number & vbCrLf & " " & Err.Description
Resume ErrExit
End Sub
Private Sub cmdOK_Click()
' Requires:
' - Function GetFolderName
'On Error GoTo ErrHandler
' Dimension variables.
Dim fs As FileSearch
Dim wb As Workbook
Dim astrParsedName() As String
Dim astrCantOpen() As String
Dim i, j As Integer
Dim strMsg As String
Application.EnableEvents = False
' Declare filesearch object.
Set fs = Application.FileSearch
' Set folder to search, subfolders, and filter
With fs
.LookIn = Me![txtFolderName]
.SearchSubFolders = True
.Filename = ".xls"
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
'Validate data
If Me![txtOPW] <> Me![txtOPWV] Then
MsgBox "Old passwords do not match."
Me!txtOPWV = ""
With Me!txtOPW
.Value = ""
.SetFocus
End With
Exit Sub
End If
If Me!txtNPW <> Me!txtNPWV Then
Me!txtNPWV = ""
With Me!txtNPW
.Value = ""
.SetFocus
End With
Exit Sub
End If
' Write new password to sheet
ActiveWorkbook.Worksheets("Splash").Activate
With ActiveWorkbook.Worksheets("Macros")
.Unprotect
.Cells(50, 2).Value = Me!txtNPW
End With
With ActiveWorkbook
.Password = Me!txtNPW
.Worksheets("Macros").Protect
.Worksheets("Splash").Visible = True
End With
Application.ScreenUpdating = False
' Loop through all files
j = 0
For i = 1 To fs.FoundFiles.Count
Set wb = Nothing
On Error Resume Next
Set wb = Workbooks.Open _
(Filename:=fs.FoundFiles.Item(i), Password:=Me![txtOPW])
On Error GoTo 0
If wb Is Nothing Then
' File has a different password; write name to astrCantOpen
array
j = j + 1
astrParsedName = Split(fs.FoundFiles.Item(i), "\")
ReDim Preserve astrCantOpen(j)
astrCantOpen(j) = astrParsedName(UBound(astrParsedName))
Else
' If file has a password, change it to the new one
If ((ActiveWorkbook.HasPassword) Or Me![chkBlank]) Then
With ActiveWorkbook
.Password = Me![txtNPW]
.Save
End With
End If
ActiveWorkbook.Close
End If
Next i
On Error GoTo ErrHandler
If j <> 0 Then
' Some files couldn't be opened
strMsg = "Couldn't open files: " & vbCrLf & vbCrLf
For i = 1 To UBound(astrCantOpen)
strMsg = strMsg & astrCantOpen(i) & vbCrLf
Next i
strMsg = strMsg & vbCrLf & vbCrLf & "Other passwords set
successfully."
MsgBox strMsg
Else
MsgBox "Password change for all files in: " & vbCrLf & vbCrLf & _
fs.LookIn & vbCrLf & vbCrLf & _
" & its subfolders was successful.", vbOKOnly, "Password Reset
Successful!"
End If
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
ErrHandler:
MsgBox "There has been the following error. Please contact the macro "
& _
"administrator." & _
vbCrLf & vbCrLf & Err.Number & vbCrLf & " " & Err.Description
Resume ErrExit
End Sub
Function GetFolderName() As Variant
On Error GoTo ErrHandler
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
' Request folder name
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then
GetFolderName = fd.SelectedItems(1)
Else
' the user pressed Cancel
GetFolderName = ""
End If
' Clean up
Set fd = Nothing
ErrExit:
Exit Function
ErrHandler:
MsgBox "There has been the following error. Please contact the macro "
& _
"administrator." & _
vbCrLf & vbCrLf & Err.Number & vbCrLf & " " & Err.Description
Resume ErrExit
End Function