Determine if file is password protected?

[bobDole2005]

As part of a security initative I am writting a program using excel vba to make sure all spreadsheets are password protected. I have a program that lists the excel files in a particular directory, but I would like it to only list files if they are NOT password protected. Is there an attribute that I can look for on the file that would tell me this??? The only way I can think of is opening the file and seeing if I get a password protect box and that takes too much time.

Thanks

 

[Tazguy37]

Welcome to MrExcel Board!

I think I found a way. The code below does go through all the files that fit the filespec and try to open them; I couldn't figure out a way to read the HasPassword Property of a closed file. Anyway, let me know how it goes. The code below goes in a standard module.

Sub detectAPassword()

Dim f As Object
Dim filesToProcess As Long
Dim fs As Object
Dim i As Long
Dim myPath As String
Dim thisEntry As String


    Application.ScreenUpdating = False

    myPath = "C:\test\"
    Range("A1:C1").Value = Array("Filename", "Date/Timestamp", "Password protected")

    With Application.FileSearch
        .NewSearch
        .LookIn = myPath
        .SearchSubFolders = True
        .Filename = "*.xls"
        .Execute
        filesToProcess = .FoundFiles.Count
        'loop through each workbook in the directory
        For i = 1 To .FoundFiles.Count
            thisEntry = .FoundFiles(i)              'get the next file
            Set fs = CreateObject("Scripting.FileSystemObject")
            Set f = fs.GetFile(thisEntry)
            ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = thisEntry
            ActiveSheet.Range("B" & Rows.Count).End(xlUp).Offset(1).Value = f.DateLastModified  'put the date in
            ActiveSheet.Range("C" & Rows.Count).End(xlUp).Offset(1).Value = False
            On Error GoTo errorHandler
            Workbooks.Open thisEntry, , , , "12345" 'try to open with this password
            ActiveWorkbook.Close 0
doNext:
        Next i
    End With

    Columns("A:C").AutoFit
    Application.ScreenUpdating = True
    Exit Sub

errorHandler:
    'we got an error, so the file has a password
    ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value = True
    GoTo doNext

End Sub

It gave me the shakes putting in a go to , but I guess I'll live through it. HTH

 

[dtchan]

You can write a program that opens up every single workbook in the folder, and then loop through the sheets and check if it is protected.

dim wks as worksheet

for each wks in worksheets

if wks.ProtectContents = false then

'do something
endif

next wks

 

[Tazguy37]

That applies to worksheets, though, not the workbook that contains them. If the workbook is protected so that you can't open it, your code will just prompt the user for a password.

Good thinking, though. I missed that in my search on protection.

 

[bobDole2005]

Thanks for the quick reply!

I'll get time to test it later this week, thanks for all your help!

 

[bobDole2005]

I was running into an issue with TazGuy's code. It worked fine on the first password protected file, but after that it would throw up an error. I did fix it this way. Many thanks to TazGuy for the original code base!

Sub lookForPassword()
Dim f As Object
Dim filesToProcess As Long
Dim fs As Object
Dim i As Long
Dim myPath As String
Dim thisEntry As String


Application.ScreenUpdating = False

myPath = "C:\test\"
Range("A1:C1").Value = Array("Filename", "Date/Timestamp", "Password protected")

With Application.FileSearch
.NewSearch
.LookIn = myPath
.SearchSubFolders = True
.Filename = "*.xls"
.Execute
filesToProcess = .FoundFiles.Count
'loop through each workbook in the directory
For i = 1 To .FoundFiles.Count
thisEntry = .FoundFiles(i) 'get the next file
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(thisEntry)
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = thisEntry
ActiveSheet.Range("B" & Rows.Count).End(xlUp).Offset(1).Value = f.DateLastModified 'put the date in
ActiveSheet.Range("C" & Rows.Count).End(xlUp).Offset(1).Value = False
Call testOpen(thisEntry)
doNext:
Next i
End With

Columns("A:C").AutoFit
Application.ScreenUpdating = True
Exit Sub

errorHandler:
'we got an error, so the file has a password
ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value = True
GoTo doNext


End Sub

Sub testOpen(fileloc As String)
On Error GoTo errorHandler
Workbooks.Open fileloc, , , , "12345" 'try to open with this password
ActiveWorkbook.Close 0
'we got an error, so the file has a password
Exit Sub
errorHandler:
ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value = True

End Sub