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