Home |
Search |
Today's Posts |
#1
![]()
Posted to microsoft.public.excel.programming
|
|||
|
|||
![]()
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 |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
Automation Error : The Object Invoked Has Disconnected From Its Clients !! | Excel Programming | |||
Error using SaveAs (object disconnected from clients!) then XL Cra | Excel Programming | |||
Automation Error: The Object Invoked Has Disconnected from Its Clients (Excel) | Excel Programming | |||
Automation Error: The Object Invoked Has Disconnected from Its Clients | Excel Programming |