VBA-在打开工作簿之前检查工作簿是否受到保护 [英] VBA - Check if a workbook is protected before open it

问题描述

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

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

注意::在此代码中，Cells(i,4).Value将等于工作簿路径..

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

推荐答案

对此有更多的思考，并提出了以下建议-尽管将需要更多的测试和可能的修改.我不喜欢默认结果是受保护，但是在我的快速测试中，我只能得到一个不受保护的文件来列出其项目.

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.

这可以通过将文件转换为zip文件，尝试导航其内容然后转换回原始类型来进行.我只用xlsx文件进行过测试，但是xlsm的原理也应相同.转换后，我将使用外壳浏览zip内容.不受保护的文件将返回其内容列表，而受保护的文件则不会.

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

使用

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

输出到立即窗口:

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

这是对探讨此问题的简短测试，我将指出，这很可能不是结论性的也不是万无一失的答案.理想情况下，我想遍历zip文件夹的内容并测试"EncryptedPackage"，但NameSpace不返回任何项目.可能有另一种方式可以做到这一点，但我没有进一步研究.

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.

受保护的Excel文件zip内容:

Protected Excel file zip contents:

不受保护的Excel文件zip内容:

Non-Protected Excel file zip contents:

使用计时器测试更新

使用来自 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

我有以下几次:

多次运行并获得相似的结果

Run this multiple times and got similar results

这篇关于VBA-在打开工作簿之前检查工作簿是否受到保护的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！