K
kthprog
This has been floating around for a while now, but I gave it a serious reworking.
Option Explicit
Public Sub AllInternalPasswords()
On Error Resume Next
'
' 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)
'
' Modified 5/7/2013 by KTH: Application.Substitute changed
' to Replace (Version 1.1.2) All integers and bools declared on one line (were
' declared individually) Layout changed, easier to read and edit
' screenupdating reenabled at end of sub
' Not wsProc And Not wbProc changed to Not (wsProc or wbProc)
' dummy do loops replaced with gotos
' some conditions now checked within if-else of pass loops
' to avoid redundancy
' complicated error checking changed to one resume next
' remove if program does not work and observe errors
' integer loop + Chr(integer) changed to for each loop through
' array of letters. should be faster
' layout changed back, still excruciatingly difficult to read
' integers should have been byte data type, since loop values were small
' doesnt matter now anyways, changed to for each
' changed to one loop unprotecting workbook and worksheets
' should be faster overall
' I actually found a use for Xor!
' overall it doesnt seem faster, but having removed
' 12 loops it seems unlikely that it's not
' worst case it takes about 13 seconds now on a good PC
' removed some of the pointlessly descriptive constants
' (like no workbook passes but there are worksheets passes
' proceeding to unprotect worksheets) very wordy and
' not important enough to add extra if conditions for
' changed to python-style layout, sorry if it bothers you
' but it's easier to read
'
' Reveals hashed passwords NOT original passwords
'
Const DBLSPACE As String = vbNewLine & vbNewLine
Const AUTHORS As String = DBLSPACE & _
"Adapted from Bob McCormick base code by " & _
"Norman Harker and JE McGimpsey " & DBLSPACE & _
"Modified: JEM 4/4/2004 " & DBLSPACE & "Modified: Kyle Hooks 5/7/2013"
Const HEADER As String = "AllInternalPasswords User Message"
Const VERSION As String = DBLSPACE & "Version 1.1.2 2013-May-07"
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 MSGNOPWORDS As String = "There were no passwords on " & _
"sheets, or workbook structure or windows." & 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 Workbook " & _
"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
Dim m As Byte
Dim AB(1) As String: AB(0) = "A": AB(1) = "B"
Dim MoreLetters() As String
For m = 32 To 126
ReDim Preserve MoreLetters(m - 32)
MoreLetters(m - 32) = Chr(m): Next
Dim wa, wb As Worksheet
Dim a, b, c, d, e, f, g, h, i, j, k, l As Variant
Dim pWord As String
Dim wsProc, wbProc, wsFound, wbFound As Boolean
wsFound = False: wbFound = False
Application.ScreenUpdating = False
With ActiveWorkbook: wbProc = .ProtectStructure Or .ProtectWindows: End With
wsProc = False
For Each wb In Worksheets: wsProc = wsProc Or wb.ProtectContents: Next
If Not (wsProc Or wbProc) Then
MsgBox MSGNOPWORDS, vbInformation, HEADER
Exit Sub: End If
MsgBox MSGTAKETIME, vbInformation, HEADER
For Each a In AB: For Each b In AB: For Each c In AB: For Each d In AB: For Each e In AB: For Each f In AB
For Each g In AB: For Each h In AB: For Each i In AB: For Each j In AB: For Each k In AB: For Each l In MoreLetters
If wbFound Xor wbProc Then ' only returns true if not equal, in this case only if the wb is protected and the pass is not found
With ActiveWorkbook
.Unprotect a & b & c & d & e & f & g & h & i & j & k & l
If Not (.ProtectStructure Or .ProtectWindows) Then
pWord = a & b & c & d & e & f & g & h & i & j & k & l
MsgBox Replace(MSGPWORDFOUND1, "$$", pWord), vbInformation, HEADER
wbFound = True: End If: End With: End If
If wsFound Xor wsProc Then
For Each wa In Worksheets
With wa
If .ProtectContents Then
.Unprotect a & b & c & d & e & f & g & h & i & j & k & l
If Not .ProtectContents Then
pWord = a & b & c & d & e & f & g & h & i & j & k & l
MsgBox Replace(MSGPWORDFOUND2, "$$", pWord), vbInformation, HEADER
wsFound = True: End If: End If: End With: Next: End If
If Not ((wbFound Xor wbProc) Or (wsFound Xor wsProc)) Then: GoTo finalize
Next: Next: Next: Next: Next: Next: Next: Next: Next: Next: Next: Next
finalize:
Application.ScreenUpdating = True
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER
End Sub
Option Explicit
Public Sub AllInternalPasswords()
On Error Resume Next
'
' 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)
'
' Modified 5/7/2013 by KTH: Application.Substitute changed
' to Replace (Version 1.1.2) All integers and bools declared on one line (were
' declared individually) Layout changed, easier to read and edit
' screenupdating reenabled at end of sub
' Not wsProc And Not wbProc changed to Not (wsProc or wbProc)
' dummy do loops replaced with gotos
' some conditions now checked within if-else of pass loops
' to avoid redundancy
' complicated error checking changed to one resume next
' remove if program does not work and observe errors
' integer loop + Chr(integer) changed to for each loop through
' array of letters. should be faster
' layout changed back, still excruciatingly difficult to read
' integers should have been byte data type, since loop values were small
' doesnt matter now anyways, changed to for each
' changed to one loop unprotecting workbook and worksheets
' should be faster overall
' I actually found a use for Xor!
' overall it doesnt seem faster, but having removed
' 12 loops it seems unlikely that it's not
' worst case it takes about 13 seconds now on a good PC
' removed some of the pointlessly descriptive constants
' (like no workbook passes but there are worksheets passes
' proceeding to unprotect worksheets) very wordy and
' not important enough to add extra if conditions for
' changed to python-style layout, sorry if it bothers you
' but it's easier to read
'
' Reveals hashed passwords NOT original passwords
'
Const DBLSPACE As String = vbNewLine & vbNewLine
Const AUTHORS As String = DBLSPACE & _
"Adapted from Bob McCormick base code by " & _
"Norman Harker and JE McGimpsey " & DBLSPACE & _
"Modified: JEM 4/4/2004 " & DBLSPACE & "Modified: Kyle Hooks 5/7/2013"
Const HEADER As String = "AllInternalPasswords User Message"
Const VERSION As String = DBLSPACE & "Version 1.1.2 2013-May-07"
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 MSGNOPWORDS As String = "There were no passwords on " & _
"sheets, or workbook structure or windows." & 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 Workbook " & _
"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
Dim m As Byte
Dim AB(1) As String: AB(0) = "A": AB(1) = "B"
Dim MoreLetters() As String
For m = 32 To 126
ReDim Preserve MoreLetters(m - 32)
MoreLetters(m - 32) = Chr(m): Next
Dim wa, wb As Worksheet
Dim a, b, c, d, e, f, g, h, i, j, k, l As Variant
Dim pWord As String
Dim wsProc, wbProc, wsFound, wbFound As Boolean
wsFound = False: wbFound = False
Application.ScreenUpdating = False
With ActiveWorkbook: wbProc = .ProtectStructure Or .ProtectWindows: End With
wsProc = False
For Each wb In Worksheets: wsProc = wsProc Or wb.ProtectContents: Next
If Not (wsProc Or wbProc) Then
MsgBox MSGNOPWORDS, vbInformation, HEADER
Exit Sub: End If
MsgBox MSGTAKETIME, vbInformation, HEADER
For Each a In AB: For Each b In AB: For Each c In AB: For Each d In AB: For Each e In AB: For Each f In AB
For Each g In AB: For Each h In AB: For Each i In AB: For Each j In AB: For Each k In AB: For Each l In MoreLetters
If wbFound Xor wbProc Then ' only returns true if not equal, in this case only if the wb is protected and the pass is not found
With ActiveWorkbook
.Unprotect a & b & c & d & e & f & g & h & i & j & k & l
If Not (.ProtectStructure Or .ProtectWindows) Then
pWord = a & b & c & d & e & f & g & h & i & j & k & l
MsgBox Replace(MSGPWORDFOUND1, "$$", pWord), vbInformation, HEADER
wbFound = True: End If: End With: End If
If wsFound Xor wsProc Then
For Each wa In Worksheets
With wa
If .ProtectContents Then
.Unprotect a & b & c & d & e & f & g & h & i & j & k & l
If Not .ProtectContents Then
pWord = a & b & c & d & e & f & g & h & i & j & k & l
MsgBox Replace(MSGPWORDFOUND2, "$$", pWord), vbInformation, HEADER
wsFound = True: End If: End If: End With: Next: End If
If Not ((wbFound Xor wbProc) Or (wsFound Xor wsProc)) Then: GoTo finalize
Next: Next: Next: Next: Next: Next: Next: Next: Next: Next: Next: Next
finalize:
Application.ScreenUpdating = True
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER
End Sub