Search for Password Protected Files

  • Thread starter Thread starter Doreen
  • Start date Start date
D

Doreen

I have a CD with a bunch of Excel files on it. I need to find the ones that
are password protected, is there by any chance a way to find such files??

Please say yes!! Thank you!

Doreen
 
Password protected--To Open or to modify????

If to Open, then this seemed to work ok:

Option Explicit
Sub testme01()

Application.ScreenUpdating = False

Dim myFiles() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim testWkbk As Workbook
Dim logWks As Worksheet
Dim oRow As Long

Set logWks = Workbooks.Add(1).Worksheets(1)
logWks.Range("a1").Resize(1, 2).Value _
= Array("Name", "Protected")

'change to point at the folder to check
myPath = "c:\my documents\excel\test"
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If

myFile = Dir(myPath & "*.xls")
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

'get the list of files
fCtr = 0
Do While myFile <> ""
fCtr = fCtr + 1
ReDim Preserve myFiles(1 To fCtr)
myFiles(fCtr) = myFile
myFile = Dir()
Loop

If fCtr > 0 Then
oRow = 2
For fCtr = LBound(myFiles) To UBound(myFiles)
Set testWkbk = Nothing
On Error Resume Next
Set testWkbk = Workbooks.Open(Filename:=myPath & myFiles(fCtr), _
UpdateLinks:=False, ReadOnly:=True, Password:="")
On Error GoTo 0

logWks.Cells(oRow, 1).Value = myPath & myFiles(fCtr)
If testWkbk Is Nothing Then
logWks.Cells(oRow, 2).Value = "Protected"
Else
logWks.Cells(oRow, 2).Value = "Unprotected"
testWkbk.Close savechanges:=False
End If
oRow = oRow + 1
Next fCtr
End If

Application.ScreenUpdating = True

End Sub

But if it was protected so that it could be opened in readonly mode, then this
didn't work.
 
Back
Top