VBA - Check if a workbook is protected before open it

Question

Is there a way to check if a workbook is protected before try to open it.

Here is my code but I have no Idea of the way (if it is possible)

Sub MySub()
Dim Wb As Workbook
For i = 14 To Cells(Rows.Count, 1).End(xlUp).Row
'I Would like to check if the workbook is Protected here

Set Wb = GetObject(Cells(i, 4).Value)



Wb.Open

End Sub

Note : In this code Cells(i,4).Value will be equal to the workbooks path..

Answer 1

Had a bit more of a think about this and came up with the following - although will need a lot more testing and probably a bit of modification. I don't like that the default result is that it is protected but in my quick test I could only get a non-protected file to list its items.

This works by converting the file to a zip file, trying to navigate its contents and then converting back to the original type. I've only tested it with xlsx files but principle should be the same for xlsm as well. Once converted I use a shell to explore the zip contents. An unprotected file will return a list of its contents, where as a protected one won't.

Public Function IsWorkbookProtected(WorkbookPath As String) As Boolean
    Dim fileExtension As String
    Dim tmpPath As Variant
    Dim sh As Object
    Dim n

    fileExtension = Right(WorkbookPath, Len(WorkbookPath) - InStrRev(WorkbookPath, "."))
    tmpPath = Left(WorkbookPath, InStrRev(WorkbookPath, ".")) & "zip"

    Name WorkbookPath As tmpPath

    Set sh = CreateObject("shell.application")
    Set n = sh.Namespace(tmpPath)

    IsWorkbookProtected = Not n.Items.Count > 0

    Name tmpPath As WorkbookPath

End Function

Called using

Sub test()
    Dim FolderPath As String
    Dim fPath1 As String, fPath2 As String

    FolderPath = "ParentFolder"

    ' protected
    fPath1 = FolderPath & "\testProtection.xlsx"
    ' unprotected
    fPath2 = FolderPath & "\testProtection - Copy.xlsx"

    Debug.Print fPath1, IsWorkbookProtected(fPath1)
    Debug.Print fPath2, IsWorkbookProtected(fPath2)
End Sub

Output to immediate window:

ParentFolder\testProtection.xlsx     True
ParentFolder\testProtection - Copy.xlsx   False

This was a brief test into exploring the issue and I will state that this is most likely not a conclusive nor fool-proof answer. Ideally I'd want to traverse the zip folder contents and test for the 'EncryptedPackage' but NameSpace wasn't returning any items. There may be another way of being able to do it but I haven't investigated further.

Protected Excel file zip contents:

Non-Protected Excel file zip contents:

Update with timer tests

Using a timer code from TheSpreadSheetGuru

Sub CalculateRunTime_Seconds()
    'PURPOSE: Determine how many seconds it took for code to completely run
    'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

    Dim StartTime As Double
    Dim SecondsElapsed As Double

    'Remember time when macro starts
      StartTime = Timer

'    Debug.Print "IsWorkbookProtected"
    Debug.Print "testOpen"

    '*****************************
    'Insert Your Code Here...
    '*****************************
'    Call testZip
    Call testOpen

    'Determine how many seconds code took to run
      SecondsElapsed = Round(Timer - StartTime, 2)

    'Notify user in seconds
      Debug.Print "This code ran successfully in " & SecondsElapsed & " seconds"

End Sub

and using the following code to test by opening the files, testing for protection and closing

Sub testOpen()
    Dim wb As Workbook
    Dim FolderPath As String
    Dim fPath1 As String, fPath2 As String
    Dim j As Long

    FolderPath = "FolderPath"

    Application.ScreenUpdating = False
    ' protected
    fPath1 = FolderPath & "\testProtection.xlsx"
    ' unprotected
    fPath2 = FolderPath & "\testProtection - Copy.xlsx"
    For j = 1 To 2

        On Error Resume Next
        Set wb = Workbooks.Open(Choose(j, fPath1, fPath2), , , , "")

        Debug.Print Choose(j, fPath1, fPath2), wb Is Nothing

        wb.Close
        On Error GoTo 0
    Next j

    Application.ScreenUpdating = True

End Sub

I got the following times:

Run this multiple times and got similar results