⑴Option Explicit
⑵Public Sub AllInternalPasswords()
⑶' Breaks worksheet and workbook structure passwords. Bob Mormick
⑷' probably originator of base code algorithm modified for coverage
⑸' of workbook structure / windows passwords and for multiple passwords
⑹' Norman Harker and JE McGimpsey -Dec- (Version .)
⑺' Modified -Apr- by JEM: All msgs to constants, and
⑻' eliminate one Exit Sub (Version ..)
⑼' Reveals hashed passwords NOT original passwords
⑽Const DBLSPACE As String = vbNewLine & vbNewLine
⑾Const AUTHORS As String = DBLSPACE & vbNewLine & _
⑿"Adapted from Bob Mormick base code by" & _
⒀"Norman Harker and JE McGimpsey"
⒁Const HEADER As String = "AllInternalPasswords User Message"
⒂Const VERSION As String = DBLSPACE & "Version .. -Apr-"
⒃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 & "Aess and use of some data " & _
⒌"may be an offense. If in doubt, don't."
⒍Const MSGNOPWORDS As String = "There were no passwords on " & _
⒎"sheets, or workbook structure or windows." & AUTHORS & VERSION
⒏Const MSGNOPWORDS 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 puter's specification." & DBLSPACE & _
⒖"Just be patient! Make me a coffee!" & AUTHORS & VERSION
⒗Const MSGPWORDFOUND 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 MSGPWORDFOUND 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 w As Worksheet, w As Worksheet
ⅡDim i As Integer, j As Integer, k As Integer, l As Integer
ⅢDim m As Integer, n As Integer, i As Integer, i As Integer
ⅣDim i As Integer, i As Integer, i As Integer, i As Integer
ⅤDim PWord As String
ⅥDim ShTag As Boolean, WinTag As Boolean
ⅦApplication.ScreenUpdating = False
ⅧWith ActiveWorkbook
ⅨWinTag = .ProtectStructure Or .ProtectWindows
ⅩEnd With
㈠ShTag = False
㈡For Each w In Worksheets
㈢ShTag = ShTag Or w.ProtectContents
㈣If Not ShTag And Not WinTag Then
㈤MsgBox MSGNOPWORDS, vbInformation, HEADER
㈥Exit Sub
㈦MsgBox MSGTAKETIME, vbInformation, HEADER
㈧If Not WinTag Then
㈨MsgBox MSGNOPWORDS, vbInformation, HEADER
㈩On Error Resume Next
Do 'dummy do loop
For i = To : For j = To : For k = To
For l = To : For m = To : For i = To
For i = To : For i = To : For i = To
For i = To : For i = To : For n = To
With ActiveWorkbook
.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i) & Chr(i) & _
Chr(i) & Chr(i) & Chr(i) & Chr(i) & Chr(n)
If .ProtectStructure = False And _
.ProtectWindows = False Then
PWord = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
Chr(m) & Chr(i) & Chr(i) & Chr(i) & _
Chr(i) & Chr(i) & Chr(i) & Chr(n)
MsgBox Application.Substitute(MSGPWORDFOUND, _
"$$", PWord), vbInformation, HEADER
Exit Do 'Bypass all for...nexts
End With
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
Loop Until True
On Error GoTo
If WinTag And Not ShTag Then
MsgBox MSGONLYONE, vbInformation, HEADER
Exit Sub
On Error Resume Next
For Each w In Worksheets
'Attempt clearance with PWord
w.Unprotect PWord
On Error GoTo
ShTag = False
For Each w In Worksheets
'Checks for all clear ShTag triggered to if not.
ShTag = ShTag Or w.ProtectContents
If ShTag Then
For Each w In Worksheets
If .ProtectContents Then
On Error Resume Next
Do 'Dummy do loop
For i = To : For j = To : For k = To
For l = To : For m = To : For i = To
For i = To : For i = To : For i = To
For i = To : For i = To : For n = To
.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i) & Chr(i) & Chr(i) & _
Chr(i) & Chr(i) & Chr(i) & Chr(n)
If Not .ProtectContents Then
PWord = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
Chr(m) & Chr(i) & Chr(i) & Chr(i) & _
Chr(i) & Chr(i) & Chr(i) & Chr(n)
MsgBox Application.Substitute(MSGPWORDFOUND, _
"$$", PWord), vbInformation, HEADER
'leverage finding Pword by trying on other sheets
For Each w In Worksheets
w.Unprotect PWord
Exit Do 'Bypass all for...nexts
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
Loop Until True
On Error GoTo
End With
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER