时间戳

首页 > 解决方案 > VBA - Check if a workbook is protected before open it

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

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

标签： excelvbapassword-protection

解决方案

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

这通过将文件转换为 zip 文件、尝试导航其内容然后转换回原始类型来工作。我只用xlsx文件测试过它，但原则也应该是一样的xlsm。转换后，我使用 shell 来探索 zip 内容。未受保护的文件将返回其内容列表，而受保护的文件则不会。

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没有返回任何项目。可能还有另一种方法可以做到这一点，但我还没有进一步调查。

受保护的 Excel 文件 zip 内容： 在此处输入图像描述

不受保护的 Excel 文件 zip 内容： 在此处输入图像描述

使用计时器测试更新

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

并使用以下代码通过打开文件、测试保护和关闭来进行测试

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

我得到了以下时间：

在此处输入图像描述

多次运行并得到类似的结果

推荐阅读