Excel 工作表，单元格破解密码宏
1
'1、 打开要破解的EXCEL文件|
2
3'2、 工具---宏----录制新宏---输入名字如:aa -----关闭
4
5'3、 工具---宏----停止录制(这样得到一个空宏)
6
7'4、 工具---宏----宏,选aa,点 编辑 按钮
8
9'5、 删除窗口中的所有字符(只有几个),替换为下面解压后文件中内容
10
11'Excel密码破解.rar
12
13'6、关闭编辑窗口
14
15'7、工具---宏-----宏,选AllInternalPasswords,运行,确定两次,等2分钟,再确定.OK,没有密码了!
16
17
18
19
20
21
22Option Explicit
23
24Public Sub AllInternalPasswords()
25' Breaks worksheet and workbook structure passwords. Bob McCormick
26' probably originator of base code algorithm modified for coverage
27' of workbook structure / windows passwords and for multiple passwords
28'
29' Norman Harker and JE McGimpsey 27-Dec-2002 (Version 1.1)
30' Modified 2003-Apr-04 by JEM: All msgs to constants, and
31' eliminate one Exit Sub (Version 1.1.1)
32' Reveals hashed passwords NOT original passwords
33Const DBLSPACE As String = vbNewLine & vbNewLine
34Const AUTHORS As String = DBLSPACE & vbNewLine & _
35"Adapted from Bob McCormick base code by" & _
36"Norman Harker and JE McGimpsey"
37Const HEADER As String = "AllInternalPasswords User Message"
38Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04"
39Const REPBACK As String = DBLSPACE & "Please report failure " & _
40"to the microsoft.public.excel.programming newsgroup."
41Const ALLCLEAR As String = DBLSPACE & "The workbook should " & _
42"now be free of all password protection, so make sure you:" & _
43DBLSPACE & "SAVE IT NOW!" & DBLSPACE & "and also" & _
44DBLSPACE & "BACKUP!, BACKUP!!, BACKUP!!!" & _
45DBLSPACE & "Also, remember that the password was " & _
46"put there for a reason. Don't stuff up crucial formulas " & _
47"or data." & DBLSPACE & "Access and use of some data " & _
48"may be an offense. If in doubt, don't."
49Const MSGNOPWORDS1 As String = "There were no passwords on " & _
50"sheets, or workbook structure or windows." & AUTHORS & VERSION
51Const MSGNOPWORDS2 As String = "There was no protection to " & _
52"workbook structure or windows." & DBLSPACE & _
53"Proceeding to unprotect sheets." & AUTHORS & VERSION
54Const MSGTAKETIME As String = "After pressing OK button this " & _
55"will take some time." & DBLSPACE & "Amount of time " & _
56"depends on how many different passwords, the " & _
57"passwords, and your computer's specification." & DBLSPACE & _
58"Just be patient! Make me a coffee!" & AUTHORS & VERSION
59Const MSGPWORDFOUND1 As String = "You had a Worksheet " & _
60"Structure or Windows Password set." & DBLSPACE & _
61"The password found was: " & DBLSPACE & "$$" & DBLSPACE & _
62"Note it down for potential future use in other workbooks by " & _
63"the same person who set this password." & DBLSPACE & _
64"Now to check and clear other passwords." & AUTHORS & VERSION
65Const MSGPWORDFOUND2 As String = "You had a Worksheet " & _
66"password set." & DBLSPACE & "The password found was: " & _
67DBLSPACE & "$$" & DBLSPACE & "Note it down for potential " & _
68"future use in other workbooks by same person who " & _
69"set this password." & DBLSPACE & "Now to check and clear " & _
70"other passwords." & AUTHORS & VERSION
71Const MSGONLYONE As String = "Only structure / windows " & _
72"protected with the password that was just found." & _
73ALLCLEAR & AUTHORS & VERSION & REPBACK
74Dim w1 As Worksheet, w2 As Worksheet
75Dim i As Integer, j As Integer, k As Integer, l As Integer
76Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer
77Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer
78Dim PWord1 As String
79Dim ShTag As Boolean, WinTag As Boolean
80
81Application.ScreenUpdating = False
82With ActiveWorkbook
83WinTag = .ProtectStructure Or .ProtectWindows
84End With
85ShTag = False
86For Each w1 In Worksheets
87ShTag = ShTag Or w1.ProtectContents
88Next w1
89If Not ShTag And Not WinTag Then
90MsgBox MSGNOPWORDS1, vbInformation, HEADER
91Exit Sub
92End If
93MsgBox MSGTAKETIME, vbInformation, HEADER
94If Not WinTag Then
95MsgBox MSGNOPWORDS2, vbInformation, HEADER
96Else
97On Error Resume Next
98Do 'dummy do loop
99For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
100For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
101For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
102For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
103With ActiveWorkbook
104.Unprotect Chr(i) & Chr(j) & Chr(k) & _
105Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
106Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
107If .ProtectStructure = False And _
108.ProtectWindows = False Then
109PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
110Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
111Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
112MsgBox Application.Substitute(MSGPWORDFOUND1, _
113"$$", PWord1), vbInformation, HEADER
114Exit Do 'Bypass all for
nexts
115End If
116End With
117Next: Next: Next: Next: Next: Next
118Next: Next: Next: Next: Next: Next
119Loop Until True
120On Error GoTo 0
121End If
122If WinTag And Not ShTag Then
123MsgBox MSGONLYONE, vbInformation, HEADER
124Exit Sub
125End If
126On Error Resume Next
127For Each w1 In Worksheets
128'Attempt clearance with PWord1
129w1.Unprotect PWord1
130Next w1
131On Error GoTo 0
132ShTag = False
133For Each w1 In Worksheets
134'Checks for all clear ShTag triggered to 1 if not.
135ShTag = ShTag Or w1.ProtectContents
136Next w1
137If ShTag Then
138For Each w1 In Worksheets
139With w1
140If .ProtectContents Then
141On Error Resume Next
142Do 'Dummy do loop
143For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
144For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
145For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
146For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
147.Unprotect Chr(i) & Chr(j) & Chr(k) & _
148Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
149Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
150If Not .ProtectContents Then
151PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
152Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
153Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
154MsgBox Application.Substitute(MSGPWORDFOUND2, _
155"$$", PWord1), vbInformation, HEADER
156'leverage finding Pword by trying on other sheets
157For Each w2 In Worksheets
158w2.Unprotect PWord1
159Next w2
160Exit Do 'Bypass all fornexts
161End If
162Next: Next: Next: Next: Next: Next
163Next: Next: Next: Next: Next: Next
164Loop Until True
165On Error GoTo 0
166End If
167End With
168Next w1
169End If
170MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER
171End Sub
'1、 打开要破解的EXCEL文件|2
3
'2、 工具---宏----录制新宏---输入名字如:aa -----关闭4
5
'3、 工具---宏----停止录制(这样得到一个空宏)6
7
'4、 工具---宏----宏,选aa,点 编辑 按钮8
9
'5、 删除窗口中的所有字符(只有几个),替换为下面解压后文件中内容10
11
'Excel密码破解.rar12
13
'6、关闭编辑窗口14
15
'7、工具---宏-----宏,选AllInternalPasswords,运行,确定两次,等2分钟,再确定.OK,没有密码了!16
17
18
19
20
21
22
Option Explicit 23
24
Public Sub AllInternalPasswords() 25
' Breaks worksheet and workbook structure passwords. Bob McCormick 26
' probably originator of base code algorithm modified for coverage 27
' of workbook structure / windows passwords and for multiple passwords 28
' 29
' Norman Harker and JE McGimpsey 27-Dec-2002 (Version 1.1) 30
' Modified 2003-Apr-04 by JEM: All msgs to constants, and 31
' eliminate one Exit Sub (Version 1.1.1) 32
' Reveals hashed passwords NOT original passwords 33
Const DBLSPACE As String = vbNewLine & vbNewLine 34
Const AUTHORS As String = DBLSPACE & vbNewLine & _ 35
"Adapted from Bob McCormick base code by" & _ 36
"Norman Harker and JE McGimpsey" 37
Const HEADER As String = "AllInternalPasswords User Message" 38
Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04" 39
Const REPBACK As String = DBLSPACE & "Please report failure " & _ 40
"to the microsoft.public.excel.programming newsgroup." 41
Const ALLCLEAR As String = DBLSPACE & "The workbook should " & _ 42
"now be free of all password protection, so make sure you:" & _ 43
DBLSPACE & "SAVE IT NOW!" & DBLSPACE & "and also" & _ 44
DBLSPACE & "BACKUP!, BACKUP!!, BACKUP!!!" & _ 45
DBLSPACE & "Also, remember that the password was " & _ 46
"put there for a reason. Don't stuff up crucial formulas " & _ 47
"or data." & DBLSPACE & "Access and use of some data " & _ 48
"may be an offense. If in doubt, don't." 49
Const MSGNOPWORDS1 As String = "There were no passwords on " & _ 50
"sheets, or workbook structure or windows." & AUTHORS & VERSION 51
Const MSGNOPWORDS2 As String = "There was no protection to " & _ 52
"workbook structure or windows." & DBLSPACE & _ 53
"Proceeding to unprotect sheets." & AUTHORS & VERSION 54
Const MSGTAKETIME As String = "After pressing OK button this " & _ 55
"will take some time." & DBLSPACE & "Amount of time " & _ 56
"depends on how many different passwords, the " & _ 57
"passwords, and your computer's specification." & DBLSPACE & _ 58
"Just be patient! Make me a coffee!" & AUTHORS & VERSION 59
Const MSGPWORDFOUND1 As String = "You had a Worksheet " & _ 60
"Structure or Windows Password set." & DBLSPACE & _ 61
"The password found was: " & DBLSPACE & "$$" & DBLSPACE & _ 62
"Note it down for potential future use in other workbooks by " & _ 63
"the same person who set this password." & DBLSPACE & _ 64
"Now to check and clear other passwords." & AUTHORS & VERSION 65
Const MSGPWORDFOUND2 As String = "You had a Worksheet " & _ 66
"password set." & DBLSPACE & "The password found was: " & _ 67
DBLSPACE & "$$" & DBLSPACE & "Note it down for potential " & _ 68
"future use in other workbooks by same person who " & _ 69
"set this password." & DBLSPACE & "Now to check and clear " & _ 70
"other passwords." & AUTHORS & VERSION 71
Const MSGONLYONE As String = "Only structure / windows " & _ 72
"protected with the password that was just found." & _ 73
ALLCLEAR & AUTHORS & VERSION & REPBACK 74
Dim w1 As Worksheet, w2 As Worksheet 75
Dim i As Integer, j As Integer, k As Integer, l As Integer 76
Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer 77
Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer 78
Dim PWord1 As String 79
Dim ShTag As Boolean, WinTag As Boolean 80
81
Application.ScreenUpdating = False 82
With ActiveWorkbook 83
WinTag = .ProtectStructure Or .ProtectWindows 84
End With 85
ShTag = False 86
For Each w1 In Worksheets 87
ShTag = ShTag Or w1.ProtectContents 88
Next w1 89
If Not ShTag And Not WinTag Then 90
MsgBox MSGNOPWORDS1, vbInformation, HEADER 91
Exit Sub 92
End If 93
MsgBox MSGTAKETIME, vbInformation, HEADER 94
If Not WinTag Then 95
MsgBox MSGNOPWORDS2, vbInformation, HEADER 96
Else 97
On Error Resume Next 98
Do 'dummy do loop 99
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 100
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 101
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 102
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 103
With ActiveWorkbook 104
.Unprotect Chr(i) & Chr(j) & Chr(k) & _ 105
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ 106
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 107
If .ProtectStructure = False And _ 108
.ProtectWindows = False Then 109
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ 110
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ 111
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 112
MsgBox Application.Substitute(MSGPWORDFOUND1, _ 113
"$$", PWord1), vbInformation, HEADER 114
Exit Do 'Bypass all fornexts 115
End If 116
End With 117
Next: Next: Next: Next: Next: Next 118
Next: Next: Next: Next: Next: Next 119
Loop Until True 120
On Error GoTo 0 121
End If 122
If WinTag And Not ShTag Then 123
MsgBox MSGONLYONE, vbInformation, HEADER 124
Exit Sub 125
End If 126
On Error Resume Next 127
For Each w1 In Worksheets 128
'Attempt clearance with PWord1 129
w1.Unprotect PWord1 130
Next w1 131
On Error GoTo 0 132
ShTag = False 133
For Each w1 In Worksheets 134
'Checks for all clear ShTag triggered to 1 if not. 135
ShTag = ShTag Or w1.ProtectContents 136
Next w1 137
If ShTag Then 138
For Each w1 In Worksheets 139
With w1 140
If .ProtectContents Then 141
On Error Resume Next 142
Do 'Dummy do loop 143
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 144
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 145
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 146
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 147
.Unprotect Chr(i) & Chr(j) & Chr(k) & _ 148
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ 149
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 150
If Not .ProtectContents Then 151
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ 152
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ 153
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 154
MsgBox Application.Substitute(MSGPWORDFOUND2, _ 155
"$$", PWord1), vbInformation, HEADER 156
'leverage finding Pword by trying on other sheets 157
For Each w2 In Worksheets 158
w2.Unprotect PWord1 159
Next w2 160
Exit Do 'Bypass all fornexts 161
End If 162
Next: Next: Next: Next: Next: Next 163
Next: Next: Next: Next: Next: Next 164
Loop Until True 165
On Error GoTo 0 166
End If 167
End With 168
Next w1 169
End If 170
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER 171
End Sub
哲学管理(学)人生, 文学艺术生活, 自动(计算机学)物理(学)工作, 生物(学)化学逆境, 历史(学)测绘(学)时间, 经济(学)数学金钱(理财), 心理(学)医学情绪, 诗词美容情感, 美学建筑(学)家园, 解构建构(分析)整合学习, 智商情商(IQ、EQ)运筹(学)生存.---Geovin Du(涂聚文）
