我在特定文件位置有 100 个受密码保护的 Excel 工作簿（2016 年），有 2 个密码我必须解锁它们

Posted 2023-02-19

【中文标题】我在特定文件位置有 100 个受密码保护的 Excel 工作簿（2016 年），有 2 个密码我必须解锁它们

【英文标题】：I have 100's of password protected excel workbooks (2016) in a specific file location, there are 2 passwords I have to unlock them

【发布时间】：2021-09-17 19:16:28

【问题描述】：

以下代码适用于从多个 Excel 文档中删除 1 个已知密码，但是如果文件夹中的文件没有正确的密码，则代码将不会继续循环遍历剩下的文件。有 2 个已知密码“191034”和“211034”，涵盖文件夹中所有受密码保护的文档。是否有可能有一段代码可以循环测试两个密码的文件，还是我需要编辑下面的代码，以便在密码不正确时继续循环，然后使用另一个密码运行单独的代码？

代码：

Sub RemovePasswords()

Dim xlBook As Workbook
Dim strFilename As String
Const fPath As String = "C:\Users\ha.smith\Documents\Excel Test\Test Files\CRU\"        'The folder to process, must end with "\"
Const strPassword As String = 211034       'case sensitive
Const strEditPassword As String = "" 'If no password use ""
    strFilename = Dir$(fPath & "*.xls") 'will open xls & xlsx etc
    While Len(strFilename) <> 0
        Application.DisplayAlerts = False
        Set xlBook = Workbooks.Open(FileName:=fPath & strFilename, _
                                    Password:=strPassword, _
                                    WriteResPassword:=strEditPassword)
        xlBook.SaveAs FileName:=fPath & strFilename, _
                      Password:="", _
                      WriteResPassword:="", _
                      CreateBackup:=False
        xlBook.Close 0
        Application.DisplayAlerts = True
        strFilename = Dir$()
    Wend
End Sub

【参考方案1】：

您只需要给它一个密码列表并尝试所有密码。如果一个失败尝试另一个。

Option Explicit

Public Sub RemovePasswords()
    Dim PasswordList() As Variant
    PasswordList = Array("191034", "211034") ' list your passwords
    
    Const strEditPassword As String = "" 'If no password use ""
    Const fPath As String = "C:\Temp\"        'The folder to process, must end with "\"

    Dim strFilename As String
    strFilename = Dir$(fPath & "*.xls") 'will open xls & xlsx etc
    
    Do While Len(strFilename) <> 0
        Application.DisplayAlerts = False
        
        Dim strPassword As Variant
        For Each strPassword In PasswordList ' loop through password list and try them all
            On Error Resume Next ' prevent error if wrong password is used
            Dim xlBook As Workbook
            Set xlBook = Workbooks.Open(Filename:=fPath & strFilename, _
                                        Password:=strPassword, _
                                        WriteResPassword:=strEditPassword)
            If Err.Number = 0 Then ' if password was correct save the file
                On Error GoTo 0
                xlBook.SaveAs Filename:=fPath & strFilename, _
                              Password:="", _
                              WriteResPassword:="", _
                              CreateBackup:=False
                xlBook.Close 0
                Exit For ' stop trying other passwords if the correct password was found.
            End If
            
            On Error GoTo 0
        Next strPassword
        
        Application.DisplayAlerts = True
        strFilename = Dir$()
    Loop
End Sub