VBA - Check if a workbook is protected before open

问题:

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..

回答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

回答2:

This is completely unsupported through any documentation but I think I found something interesting. I'm curious for other oppinions on this.

---

Hypothesis

So, each time I went through all my file properties, there was one property that seemingly changed when a file was password protected, this was property 42 (being the "Program name"), part of the extended file properties. See screenshot below (by @Tom), where the left is an unprotected file and the right is protected.

Everytime I unprotected a workbook, a value showed up, e.g "Microsoft Excel" or even sometimes "Microsoft Excel Online". However, on all cases I protected the workbook, the value was empty. Hence, that left me thinking that looking at this specific property is telling us in some way that the file is protected when the property is empty. Might this because the property can't be read because of the protection?

With the help of @Tom we found that this property's index can differ. While on my system this property has got index 42, it appeared that at Tom's system it would sit under 8. Therefor he kindly implemented a smart loop to return the right index before looping the files. Noteworthy: The property's name is language dependent! For Dutch, I would look for "Programmanaam" for example.

---

Code

Using the following code we can go through a specific folder and loop files to return the value of this specific property:

Sub MySub()

Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir:   Set oDir = oShell.Namespace("C:\Users\...\")
Dim i as long, x as long

For i = 0 To 288
    If oDir.GetDetailsOf(oDir.Items, i) = "Program name" Then
        x = i
        Exit For
    End If
Next i

For Each sFile In oDir.Items
    If oDir.GetDetailsOf(sFile, x) = "" Then
        Debug.Print sFile.Name & " is protected"
    Else
        Debug.Print sFile.Name & " is unprotected and can be openened"
    End If
Next

End Sub

---

To adapt that a bit more to loop a range and check a bunch of workbook names that could look like:

Working code looks like:

Sub MySub()

Dim MainPath As String: MainPath = "C:\Users\...\"
Dim i As Long, x As Long
Dim oDir As Object: Set oDir = CreateObject("Shell.Application").Namespace(CStr(MainPath))

'Get the right index for property "Program Name"
For i = 0 To 288
    If oDir.GetDetailsOf(oDir.Items, i) = "Program Name" Then
        x = i
        Exit For
    End If
Next i

'Loop the range of workbooks and check whether or not they are protected
With ThisWorkbook.Sheets("Sheet1") 'Change accordingly
    For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
        If oDir.GetDetailsOf(oDir.Items.Item(CStr(.Cells(i, 1))), x) = "" Then
            Debug.Print .Cells(i, 1) & " is protected"
        Else
            Debug.Print .Cells(i, 1) & " is unprotected and can be openened"
            'Open your workbook here?
        End If
    Next i
End With

End Sub

Note: Please notice the use of Cstr() on both the MainPath and the cell's value. It's as far as I know not very clear why, but without it, the code will return an 'Error 445: Object doesn't support this action' Update: Check this question for some more insight on this specific issue.

---

Example

For example, I have the following workbooks, with Map2 and Map5 protected:

Immediate window after running the first macro:

Next I only protected map1 and map3 with the following result:

---

Conclusion

Hypothesis proven? I don't know, but on my end there has not been a single time the hypothesis has been proven wrong. Again, there is no documentation on this. But this might just be your way into knowing very quickly if a workbook is protected or not.

Btw, I borrowed some code form here

回答3:

Maybe this will not fully satisfy You, but maybe help a little bit.

Sub checkif()

On Error GoTo ErrHand

    Dim obj As Object
    Dim strFileName

    strFileName = "filepath"

    Set obj = Workbooks.Open(strFileName, , , , "")

    Exit Sub
ErrHand:

    If Err() = 1004 Then
        MsgBox "Protected"
    End If

End Sub