撤销EXCLE工作表保护密码

本是古典何须时尚 2022-11-27 07:10 198阅读 0赞

### 撤销工作表密码保护 ###

*  有时工作簿太长时间没用，可能会忘掉工作表的保护密码以致无法编辑，本代码能快速有效解决此问题

# 有时工作簿太长时间没用，可能会忘掉工作表的保护密码以致无法编辑，本代码能快速有效解决此问题 #

Option Explicit
    
    Public Sub AllInternalPasswords()
        ' 中断工作表和工作簿结构密码
        ' 算法创始人Bob McCormick
        ' Norman Harker / JE McGimpsey 2002年12月27日（1.1版）
        ' 2003-Apr-04修改：所有msg为常量
        ' 显示哈希密码而不是原始密码
        
        Const DBLSPACE As String = vbNewLine & vbNewLine
        Const AUTHORS As String = DBLSPACE & vbNewLine & "Adapted from Bob McCormick base code by" & "Norman Harker and JE McGimpsey"
        Const HEADER As String = "AllInternalPasswords User Message"
        Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04"
        Const REPBACK As String = DBLSPACE & "Please report failure " & "to the microsoft.public.excel.programming newsgroup."
        Const ALLCLEAR As String = DBLSPACE & "The workbook should " & "now be free of all password protection, so make sure you:" & DBLSPACE & "SAVE IT NOW!" & DBLSPACE & "and also" & DBLSPACE & "BACKUP!, BACKUP!!, BACKUP!!!" & DBLSPACE & "Also, remember that the password was " & "put there for a reason. Don't stuff up crucial formulas " & "or data." & DBLSPACE & "Access and use of some data " & "may be an offense. If in doubt, don't."
        Const MSGNOPWORDS1 As String = "There were no passwords on " & "sheets, or workbook structure or windows." & AUTHORS & VERSION
        Const MSGNOPWORDS2 As String = "There was no protection to " & "workbook structure or windows." & DBLSPACE & "Proceeding to unprotect sheets." & AUTHORS & VERSION
        Const MSGTAKETIME As String = "After pressing OK button this " & "will take some time." & DBLSPACE & "Amount of time " & "depends on how many different passwords, the " & "passwords, and your computer's specification." & DBLSPACE & "Just be patient! Make me a coffee!" & AUTHORS & VERSION
        Const MSGPWORDFOUND1 As String = "You had a Worksheet " & "Structure or Windows Password set." & DBLSPACE & "The password found was: " & DBLSPACE & "$$" & DBLSPACE & "Note it down for potential future use in other workbooks by " & "the same person who set this password." & DBLSPACE & "Now to check and clear other passwords." & AUTHORS & VERSION
        Const MSGPWORDFOUND2 As String = "You had a Worksheet " & "password set." & DBLSPACE & "The password found was: " & DBLSPACE & "$$" & DBLSPACE & "Note it down for potential " & "future use in other workbooks by same person who " & "set this password." & DBLSPACE & "Now to check and clear " & "other passwords." & AUTHORS & VERSION
        Const MSGONLYONE As String = "Only structure / windows " & "protected with the password that was just found." & ALLCLEAR & AUTHORS & VERSION & REPBACK
        
        Dim w1 As Worksheet, w2 As Worksheet
        Dim i As Integer, j As Integer, k As Integer, l As Integer
        Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer
        Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer
        Dim PWord1 As String
        Dim ShTag As Boolean, WinTag As Boolean
         
        Application.ScreenUpdating = False
        With ActiveWorkbook
            WinTag = .ProtectStructure Or .ProtectWindows
        End With
        
        ShTag = False
        For Each w1 In Worksheets
            ShTag = ShTag Or w1.ProtectContents
        Next w1
        
        If Not ShTag And Not WinTag Then
            MsgBox MSGNOPWORDS1, vbInformation, HEADER
            Exit Sub
        End If
        MsgBox MSGTAKETIME, vbInformation, HEADER
        
        If Not WinTag Then
            MsgBox MSGNOPWORDS2, vbInformation, HEADER
        Else
            On Error Resume Next
            Do
                For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
                For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
                For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
                For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
                    With ActiveWorkbook
                        .Unprotect Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
                        If .ProtectStructure = False And .ProtectWindows = False Then
                            PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
                            MsgBox Application.Substitute(MSGPWORDFOUND1, "$$", PWord1), vbInformation, HEADER
                            Exit Do
                        End If
                    End With
                Next: Next: Next: Next: Next: Next
                Next: Next: Next: Next: Next: Next
            Loop Until True
            On Error GoTo 0
        End If
        
        If WinTag And Not ShTag Then
            MsgBox MSGONLYONE, vbInformation, HEADER
            Exit Sub
        End If
        
        On Error Resume Next
        For Each w1 In Worksheets
            '尝试用PWord1清除
            w1.Unprotect PWord1
        Next w1
        
        On Error GoTo 0
        ShTag = False
        For Each w1 In Worksheets
            '检查所有清除ShTag是否触发为1
            ShTag = ShTag Or w1.ProtectContents
        Next w1
        
        If ShTag Then
            For Each w1 In Worksheets
                With w1
                    If .ProtectContents Then
                        On Error Resume Next
                        Do
                            For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
                            For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
                            For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
                            For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
                            .Unprotect Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
                            If Not .ProtectContents Then
                                PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
                                MsgBox Application.Substitute(MSGPWORDFOUND2, "$$", PWord1), vbInformation, HEADER
                                '尝试在其他表格上找到Password
                                For Each w2 In Worksheets
                                    w2.Unprotect PWord1
                                Next w2
                                Exit Do
                            End If
                            Next: Next: Next: Next: Next: Next
                            Next: Next: Next: Next: Next: Next
                        Loop Until True
                        On Error GoTo 0
                    End If
                End With
            Next w1
        End If
        MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER
        
    End Sub