Excel解除'工作表保护密码'，并复原密码设定

前言

适用环境

  1. Office 2003（也就是老版的.xls文件）

  2. 用到宏操作

  3. 可以解除【审阅->保护工作表】的密码保护，其他的密码保护不能处理。

解决

具体步骤

  1. 打开需解除保护密码的Excel文件（.xls）；

  2. 从菜单栏里找到并打开【录制宏】；

    

  3. 直接点击【停止录制】（这样得到一个空宏）；

  4. 点击【宏】，找到刚刚录制的宏，点击编辑；

  5. 删除窗口中的所有代码,替换为下面的内容；

  6. 如果菜单没有上述描述的按钮，可以在【文件->选项->自定义功能区】找

  7. Ctrl+S保存关闭编辑窗口；

  8. 点击【宏】，找到刚刚编辑的宏【AllInternalPasswords】，点击执行，按照提示信息操作；

  9. 等待一会弹窗会有下面的提示，这样就是成功了！（记得保存弹窗中的密码，后面要用）

  10. 这时密码已经被清除掉了，你就可以随意修改文件内容了，如果想恢复原来的密码状态，重新点击【审阅->保护工作表】把弹窗中找到的密码原封不动的拷贝进去，并保存，这样原来的密码也可以用，这个密码也可以用

直接选中窗口按Ctrl+C就能拷贝窗口的全部文字，可以先粘贴到文本编辑器里再取获得的密码

  

代码

宏

Option Explicit

Public Sub AllInternalPasswords()
' Breaks worksheet and workbook structure passwords. Bob McCormick
' probably originator of base code algorithm modified for coverage
' of workbook structure / windows passwords and for multiple passwords
'
' Norman Harker and JE McGimpsey 27-Dec-2002 (Version 1.1)
' Modified 2003-Apr-04 by JEM: All msgs to constants, and
' eliminate one Exit Sub (Version 1.1.1)
' Reveals hashed passwords NOT original passwords
Const DBLSPACE As String = vbNewLine & vbNewLine
Const AUTHORS As String = DBLSPACE & vbNewLine & _
"改编自Bob McCormick的代码。"
Const HEADER As String = "重置密码"
Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04"
Const REPBACK As String = DBLSPACE & "感谢使用！"
Const ALLCLEAR As String = DBLSPACE & "工作簿现在应该没有任何密码保护，因此请确保：" & _
DBLSPACE & "立即保存!" & DBLSPACE & "并且" & _
DBLSPACE & "备份!, 备份!!, 备份!!!"
Const MSGNOPWORDS1 As String = "工作表、工作簿结构或窗口上没有密码。" & AUTHORS & VERSION
Const MSGNOPWORDS2 As String = "对工作簿结构或窗口没有保护" & _
"。" & DBLSPACE & _
"继续取消工作表保护。" & AUTHORS & VERSION
Const MSGTAKETIME As String = "按下OK按钮后，会需要花费一些时间" & _
"。" & DBLSPACE & "这个时间的长短取决于密码的难度和电脑的性能" & _
"。" & DBLSPACE & _
"请耐心等待，或者先去喝杯茶!" & AUTHORS & VERSION
Const MSGPWORDFOUND1 As String = "您设置了工作表结构或Windows密码" & _
"。" & DBLSPACE & _
"找到的密码是：" & DBLSPACE & "$$" & DBLSPACE & _
"请记下来，以备将来由设置此密码" & _
"的同一个人在其他工作簿中使用" & DBLSPACE & _
"现在检查并清除其他密码" & AUTHORS & VERSION
Const MSGPWORDFOUND2 As String = "您设置了工作表密码" & _
"。" & DBLSPACE & "找到的密码是：" & _
DBLSPACE & "$$" & DBLSPACE & "请记下来，以备将来由设置此密码" & _
"的同一个人在其他工作簿中使用" & _
"。" & DBLSPACE & "现在检查并清除其他密码" & _
"。" & AUTHORS & VERSION
Const MSGONLYONE As String = "只有使用刚找到的密码保护的结构/窗口。" & _
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 'dummy do loop
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 'Bypass all for...nexts
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
'Attempt clearance with PWord1
w1.Unprotect PWord1
Next w1
On Error GoTo 0
ShTag = False
For Each w1 In Worksheets
'Checks for all clear ShTag triggered to 1 if not.
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 'Dummy do loop
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
'leverage finding Pword by trying on other sheets
For Each w2 In Worksheets
w2.Unprotect PWord1
Next w2
Exit Do 'Bypass all for...nexts
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