Automation Error: Object Disconnected From Clients
 

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

Automation Error: Object Disconnected From Clients
 

I've isolated the error to the line:

If wb Is Nothing Then

I don't understand how wb could be disassociated. Does anyone know?

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
Dim strResponse As String

Application.EnableEvents = False

' Declare 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
'Validate 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
Me![txtNPW] = ""
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
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

' Write new password to sheet
Me.Hide
ActiveWorkbook.Worksheets("Splash").Activate
With ActiveWorkbook.Worksheets("Macros")
.Unprotect
.Cells(50, 2).Value = Me![txtNPW]
End With

With ActiveWorkbook
If Me![txtNPW] = "" Then
.Password = ""
Else
.Password = Me![txtNPW]
End If
.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
On Error Resume Next

Set wb = Workbooks.Open _
(Filename:=fs.FoundFiles.Item(i), Password:=Me![txtOPW])
' This Msgbox shows
MsgBox "Opened " & wb.Name
If wb Is Nothing Then
' This one doesn't; error displayed
MsgBox "Inside If wb Is Nothing block"
MsgBox "inside If wb is nothing"
' 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

If j < 0 Then
MsgBox "inside If j<0"
' 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
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
Unload Me
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