Option Explicit
PublicSub AllInternalPasswords()' 中断工作表和工作簿结构密码' 算法创始人Bob McCormick' Norman Harker / JE McGimpsey 2002年12月27日(1.1版)' 2003-Apr-04修改:所有msg为常量' 显示哈希密码而不是原始密码Const DBLSPACE AsString= vbNewLine & vbNewLine
Const AUTHORS AsString= DBLSPACE & vbNewLine &"Adapted from Bob McCormick base code by"&"Norman Harker and JE McGimpsey"Const HEADER AsString="AllInternalPasswords User Message"Const VERSION AsString= DBLSPACE &"Version 1.1.1 2003-Apr-04"Const REPBACK AsString= DBLSPACE &"Please report failure "&"to the microsoft.public.excel.programming newsgroup."Const ALLCLEAR AsString= 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 AsString="There were no passwords on "&"sheets, or workbook structure or windows."& AUTHORS & VERSION
Const MSGNOPWORDS2 AsString="There was no protection to "&"workbook structure or windows."& DBLSPACE &"Proceeding to unprotect sheets."& AUTHORS & VERSION
Const MSGTAKETIME AsString="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 AsString="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 AsString="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 AsString="Only structure / windows "&"protected with the password that was just found."& ALLCLEAR & AUTHORS & VERSION & REPBACK
Dim w1 As Worksheet, w2 As Worksheet
Dim i AsInteger, j AsInteger, k AsInteger, l AsIntegerDim m AsInteger, n AsInteger, i1 AsInteger, i2 AsIntegerDim i3 AsInteger, i4 AsInteger, i5 AsInteger, i6 AsIntegerDim PWord1 AsStringDim ShTag AsBoolean, WinTag AsBoolean
Application.ScreenUpdating =FalseWith ActiveWorkbook
WinTag = .ProtectStructure Or .ProtectWindows
EndWith
ShTag =FalseFor Each w1 In Worksheets
ShTag = ShTag Or w1.ProtectContents
Next w1
IfNot ShTag AndNot WinTag Then
MsgBox MSGNOPWORDS1, vbInformation, HEADER
ExitSubEndIf
MsgBox MSGTAKETIME, vbInformation, HEADER
IfNot WinTag Then
MsgBox MSGNOPWORDS2, vbInformation, HEADER
ElseOn ErrorResumeNextDoFor i =65To66:For j =65To66:For k =65To66For l =65To66:For m =65To66:For i1 =65To66For i2 =65To66:For i3 =65To66:For i4 =65To66For i5 =65To66:For i6 =65To66:For n =32To126With 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 =FalseAnd .ProtectWindows =FalseThen
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
ExitDoEndIfEndWithNext:Next:Next:Next:Next:NextNext:Next:Next:Next:Next:NextLoopUntilTrueOn ErrorGoTo0EndIfIf WinTag AndNot ShTag Then
MsgBox MSGONLYONE, vbInformation, HEADER
ExitSubEndIfOn ErrorResumeNextFor Each w1 In Worksheets
'尝试用PWord1清除
w1.Unprotect PWord1
Next w1
On ErrorGoTo0
ShTag =FalseFor Each w1 In Worksheets
'检查所有清除ShTag是否触发为1
ShTag = ShTag Or w1.ProtectContents
Next w1
If ShTag ThenFor Each w1 In Worksheets
With w1
If .ProtectContents ThenOn ErrorResumeNextDoFor i =65To66:For j =65To66:For k =65To66For l =65To66:For m =65To66:For i1 =65To66For i2 =65To66:For i3 =65To66:For i4 =65To66For i5 =65To66:For i6 =65To66:For n =32To126
.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)IfNot .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
'尝试在其他表格上找到PasswordFor Each w2 In Worksheets
w2.Unprotect PWord1
Next w2
ExitDoEndIfNext:Next:Next:Next:Next:NextNext:Next:Next:Next:Next:NextLoopUntilTrueOn ErrorGoTo0EndIfEndWithNext w1
EndIf
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER
EndSub