VBA-在打开工作簿之前检查工作簿是否受到保护

Question

有没有办法在尝试打开工作簿之前检查工作簿是否受到保护。

这是我的代码，但我不知道方法（如果可能）

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

注意：此代码中的代码Cells(i,4).Value将等于工作簿路径。

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

Answer 2

任何文档都完全不支持这一点，但我想我发现了一些有趣的东西。我很好奇关于这个的其他意见。

假设

因此，每次我查看所有文件属性时，都有一个属性在文件受密码保护时似乎发生了变化，这是属性 42（即“程序名称”），它是扩展文件属性的一部分。请参阅下面的屏幕截图（@Tom），其中左侧是未受保护的文件，右侧是受保护的文件。

每次我取消保护工作簿时，都会显示一个值，例如“Microsoft Excel”，有时甚至是“Microsoft Excel Online”。但是，在我保护工作簿的所有情况下，该值为空。因此，这让我认为查看此特定属性会以某种方式告诉我们，当该属性为空时，该文件受到保护。这可能是因为由于保护而无法读取该属性吗？

在@Tom 的帮助下，我们发现此属性的索引可能有所不同。虽然在我的系统上，这个属性的索引为 42，但在 Tom 的系统中，它似乎低于 8。因此，他好心地实现了一个智能循环，以便在循环文件之前返回正确的索引。值得注意的是：该属性的名称取决于语言！例如，对于荷兰语，我会寻找“Programmanaam”。

代码

使用以下代码，我们可以遍历特定文件夹和循环文件以返回此特定属性的值：

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

再调整一下以循环一个范围并检查一堆可能如下所示的工作簿名称：

工作代码如下所示：

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

注意：请注意Cstr()MainPath 和单元格值上的使用。据我所知不是很清楚为什么，但没有它，代码将返回“错误 445：对象不支持此操作”更新：检查 此 问题以了解有关此特定问题的更多信息。

例子

例如，我有以下工作簿，其中 Map2 和 Map5 受到保护：

运行第一个宏后的立即窗口：

接下来我只保护了 map1 和 map3，结果如下：

结论

假设得到证实？我不知道，但在我看来，这个假设从来没有被证明是错误的。同样，没有关于此的文档。但这可能只是您快速了解工作簿是否受保护的方式。

顺便说一句，我在这里借用了一些代码表格