Microsoft-office 常见问题

  1 Public Sub AllInternalPasswords()
  2 ‘ Breaks worksheet and workbook structure passwords. Bob McCormick
  3 ‘ probably originator of base code algorithm modified for coverage
  4 ‘ of workbook structure / windows passwords and for multiple passwords
  5 ‘
  6 ‘ Norman Harker and JE McGimpsey 27-Dec-2002 (Version 1.1)
  7 ‘ Modified 2003-Apr-04 by JEM: All msgs to constants, and
  8 ‘ eliminate one Exit Sub (Version 1.1.1)
  9 ‘ Reveals hashed passwords NOT original passwords
 10 Const DBLSPACE As String = vbNewLine & vbNewLine
 11 Const AUTHORS As String = DBLSPACE & vbNewLine & _
 12 "Adapted from Bob McCormick base code by" & _
 13 "Norman Harker and JE McGimpsey"
 14 Const HEADER As String = "AllInternalPasswords User Message"
 15 Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04"
 16 Const REPBACK As String = DBLSPACE & "Please report failure " & _
 17 "to the microsoft.public.excel.programming newsgroup."
 18 Const ALLCLEAR As String = DBLSPACE & "The workbook should " & _
 19 "now be free of all password protection, so make sure you:" & _
 20 DBLSPACE & "SAVE IT NOW!" & DBLSPACE & "and also" & _
 21 DBLSPACE & "BACKUP!, BACKUP!!, BACKUP!!!" & _
 22 DBLSPACE & "Also, remember that the password was " & _
 23 "put there for a reason. Don‘t stuff up crucial formulas " & _
 24 "or data." & DBLSPACE & "Access and use of some data " & _
 25 "may be an offense. If in doubt, don‘t."
 26 Const MSGNOPWORDS1 As String = "There were no passwords on " & _
 27 "sheets, or workbook structure or windows." & AUTHORS & VERSION
 28 Const MSGNOPWORDS2 As String = "There was no protection to " & _
 29 "workbook structure or windows." & DBLSPACE & _
 30 "Proceeding to unprotect sheets." & AUTHORS & VERSION
 31 Const MSGTAKETIME As String = "After pressing OK button this " & _
 32 "will take some time." & DBLSPACE & "Amount of time " & _
 33 "depends on how many different passwords, the " & _
 34 "passwords, and your computer‘s specification." & DBLSPACE & _
 35 "Just be patient! Make me a coffee!" & AUTHORS & VERSION
 36 Const MSGPWORDFOUND1 As String = "You had a Worksheet " & _
 37 "Structure or Windows Password set." & DBLSPACE & _
 38 "The password found was: " & DBLSPACE & "$$" & DBLSPACE & _
 39 "Note it down for potential future use in other workbooks by " & _
 40 "the same person who set this password." & DBLSPACE & _
 41 "Now to check and clear other passwords." & AUTHORS & VERSION
 42 Const MSGPWORDFOUND2 As String = "You had a Worksheet " & _
 43 "password set." & DBLSPACE & "The password found was: " & _
 44 DBLSPACE & "$$" & DBLSPACE & "Note it down for potential " & _
 45 "future use in other workbooks by same person who " & _
 46 "set this password." & DBLSPACE & "Now to check and clear " & _
 47 "other passwords." & AUTHORS & VERSION
 48 Const MSGONLYONE As String = "Only structure / windows " & _
 49 "protected with the password that was just found." & _
 50 ALLCLEAR & AUTHORS & VERSION & REPBACK
 51 Dim w1 As Worksheet, w2 As Worksheet
 52 Dim i As Integer, j As Integer, k As Integer, l As Integer
 53 Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer
 54 Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer
 55 Dim PWord1 As String
 56 Dim ShTag As Boolean, WinTag As Boolean
 57 Application.ScreenUpdating = False
 58 With ActiveWorkbook
 59 WinTag = .ProtectStructure Or .ProtectWindows
 60 End With
 61 ShTag = False
 62 For Each w1 In Worksheets
 63 ShTag = ShTag Or w1.ProtectContents
 64 Next w1
 65 If Not ShTag And Not WinTag Then
 66 MsgBox MSGNOPWORDS1, vbInformation, HEADER
 67 Exit Sub
 68 End If
 69 MsgBox MSGTAKETIME, vbInformation, HEADER
 70 If Not WinTag Then
 71 MsgBox MSGNOPWORDS2, vbInformation, HEADER
 72 Else
 73 On Error Resume Next
 74 Do ‘dummy do loop
 75 For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
 76 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
 77 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
 78 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
 79 With ActiveWorkbook
 80 .Unprotect Chr(i) & Chr(j) & Chr(k) & _
 81 Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
 82 Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
 83 If .ProtectStructure = False And _
 84 .ProtectWindows = False Then
 85 PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
 86 Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
 87 Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
 88 MsgBox Application.Substitute(MSGPWORDFOUND1, _
 89 "$$", PWord1), vbInformation, HEADER
 90 Exit Do ‘Bypass all for...nexts
 91 End If
 92 End With
 93 Next: Next: Next: Next: Next: Next
 94 Next: Next: Next: Next: Next: Next
 95 Loop Until True
 96 On Error GoTo 0
 97 End If
 98 If WinTag And Not ShTag Then
 99 MsgBox MSGONLYONE, vbInformation, HEADER
100 Exit Sub
101 End If
102 On Error Resume Next
103 For Each w1 In Worksheets
104 ‘Attempt clearance with PWord1
105 w1.Unprotect PWord1
106 Next w1
107 On Error GoTo 0
108 ShTag = False
109 For Each w1 In Worksheets
110 ‘Checks for all clear ShTag triggered to 1 if not.
111 ShTag = ShTag Or w1.ProtectContents
112 Next w1
113 If ShTag Then
114 For Each w1 In Worksheets
115 With w1
116 If .ProtectContents Then
117 On Error Resume Next
118 Do ‘Dummy do loop
119 For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
120 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
121 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
122 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
123 .Unprotect Chr(i) & Chr(j) & Chr(k) & _
124 Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
125 Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
126 If Not .ProtectContents Then
127 PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
128 Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
129 Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
130 MsgBox Application.Substitute(MSGPWORDFOUND2, _
131 "$$", PWord1), vbInformation, HEADER
132 ‘leverage finding Pword by trying on other sheets
133 For Each w2 In Worksheets
134 w2.Unprotect PWord1
135 Next w2
136 Exit Do ‘Bypass all for...nexts
137 End If
138 Next: Next: Next: Next: Next: Next
139 Next: Next: Next: Next: Next: Next
140 Loop Until True
141 On Error GoTo 0
142 End If
143 End With
144 Next w1
145 End If
146 MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER
147 End Sub