vba项目属性密码

Question

我有一个工作簿，它处理一系列输入工作簿，其中一些已设置VBA密码但未锁定以供查看 - 即无需密码即可导航vb代码，但需要密码才能查看项目属性（例如工具/参考）。在这种情况下，即使设置了密码，VBProject.Protection也会设置为vbext_pp_none。我可以检查什么来检测“查看项目属性的密码”是​​否存在？

Answer 1

当您保护该项目时，您必须勾选该框并提供密码。

• 如果没有如果你打勾的框，供您将提示您添加密码的密码才能继续

换句话说滴答作响的保护不被应用于

盒提供密码，但你的逻辑是有意义的，但不会发生（我知道（我在Excel 2010上测试过）），它可以是vbext_pp_none（0）或vbext_pp_locked（1）。

编辑/补充： -

阅读您的意见后，我无法重现的情况，但在所有版本/平台，我无法想象这是不可能的。下面是一个例子，通过这个例子，一个属性在错误捕获过程中试图改变，如果它成功了，那么它根本就没有被锁定。

Public Sub Sample() 
Dim WkBk As Workbook 

Set WkBk = Application.Workbooks.Open(Environ("UserProfile") & "\Desktop\Book1.xlsm") 
    If WkBk.VBProject.Protection = 1 Then 'vbext_pp_locked then 
     MsgBox "It is locked" 
    Else 
     If LockedForEdits(WkBk) Then 
      MsgBox "It is locked for edits" 
     Else 
      MsgBox "It is not locked" 
     End If 
    End If 
    WkBk.Close 0 
Set WkBk = Nothing 
End Sub 

Private Function LockedForEdits(ByRef WkBk As Workbook) As Boolean 
Dim StrDescription As String 

On Error GoTo ErrorHandle 

StrDescription= WkBk.VBProject.Description 
WkBk.VBProject.Description = WkBk.VBProject.Description & "TEST" 
WkBk.VBProject.Description = StrDescription 

Exit Function 
ErrorHandle: 
Err.Clear 
LockedForEdits = True 
End Function 

Answer 2

下面的代码依赖于不存在问题，但如果使用Excel 2010在PC上专门工作（测试）或2007（未测试），它会自动侦测出密码的存在，并与代码一起信息你已经有了并且在上一个答案中编码，它应该回答检测密码存在方式的问题。

最新的办公文件格式是zip包，为此您可以将其从.xlsm重命名为.zip并查看其内容。在zip包中，xl文件夹中可能有bin文件（如果文件中没有VBA，则不存在）。在bin文件中有一个名为'DPB'的字符串值，该值被加密，但如果有密码，则该值很长，因此可以通过'DPB'值的长度检测到密码的存在。

下面的代码将受益于重要的错误处理，因为有很多文件操作发生，并且如前所述，这与前一个答案中代码的更改版本一起使用，应提供答案题。

下面的代码需要添加'Windows Scripting Runtime'引用（Tools> References> tick'Windows Scripting Runtime'），我没有迟到绑定使它更快更清晰。我也评论整个代码来描述发生了什么

Public Sub Sample() 
Dim FSO    As New FileSystemObject 
Dim Shl    As Object 
Dim Fl    As Scripting.File 
Dim Fldr   As Scripting.Folder 
Dim LngCounter  As Long 
Dim Ts    As Scripting.TextStream 
Dim StrTmpFldr  As String 
Dim StrWkBk   As String 
Dim StrWkBkName  As String 
Dim StrContainer As String 
Dim WkBk   As Excel.Workbook 

'A place to work with temp files, for my own ease I done it on the desktop 
'but this is not good practice 
StrTmpFldr = Environ("UserProfile") & "\Desktop\" 

'A path to a workbook (may be passed in) 
StrWkBk = Environ("UserProfile") & "\Desktop\Book4.xlsm" 

'We need the file name seperate from the path 
StrWkBkName = Right(StrWkBk, Len(StrWkBk) - InStrRev(StrWkBk, "\")) 

'Copy the workbook and change it to a .zip (xlsx, and other new forms are zip packages) 
FSO.CopyFile StrWkBk, StrTmpFldr & Left(StrWkBkName, InStrRev(StrWkBkName, ".")) & "zip", True 

'Create a folder to extract the zip to 
FSO.CreateFolder StrTmpFldr & Left(StrWkBkName, InStrRev(StrWkBkName, ".") - 1) 

'Unzip it into the folder we created 
Set Shl = CreateObject("Shell.Application") 
    Shl.Namespace(StrTmpFldr & Left(StrWkBkName, InStrRev(StrWkBkName, ".") - 1) & "\").CopyHere Shl.Namespace(StrTmpFldr & Left(StrWkBkName, InStrRev(StrWkBkName, ".")) & "zip").Items 
Set Shl = Nothing 

'Delete the zip 
FSO.DeleteFile StrTmpFldr & Left(StrWkBkName, InStrRev(StrWkBkName, ".")) & "zip", True 

Set Fldr = FSO.GetFolder(StrTmpFldr & Left(StrWkBkName, InStrRev(StrWkBkName, ".") - 1) & "\xl\") 

    'Is there a project file? (there won't be if there is no code in it) 
    For Each Fl In Fldr.Files 
     If Right(Fl.Name, 4) = ".bin" Then Exit For 
    Next 

    If Fl Is Nothing Then 
     MsgBox "It is not protected" 
    Else 
     'Parse the file looking for the line starting "DPB="" if the value in here is over 25 long, 
     'then it is storing a password 
     Set Ts = Fl.OpenAsTextStream(ForReading) 
      Do Until Ts.AtEndOfStream 
       StrContainer = Ts.ReadLine 
       If Left(StrContainer, 5) = "DPB=" & """" Then 
        StrContainer = Replace(Replace(StrContainer, "DPB=", ""), """", "") 
        If Len(StrContainer) > 25 Then 
         MsgBox "It is protected" 
        Else 
         MsgBox "It is not protected" 
        End If 
        Exit Do 
       End If 
      Loop 
      Ts.Close 
     Set Ts = Nothing 
     Set Fl = Nothing 
    End If 

Set Fldr = Nothing 

'Delete the folder 
FSO.DeleteFolder StrTmpFldr & Left(StrWkBkName, InStrRev(StrWkBkName, ".") - 1), True 

End Sub