Public Sub 工作表保护密码破解() /Ri,>}n
Const DBLSPACE As String = vbNewLine & vbNewLine Q>IH``1*e
Const AUTHORS As String = DBLSPACE & vbNewLine & _ sPpS~wk*
"作者:XXXXXXX" _[1^s$
Const HEADER As String = "工作表保护密码破解" G{A)H_o*
Const VERSION As String = DBLSPACE & "版本 Version 1.1.1" kV 1vb
Const REPBACK As String = DBLSPACE & "" gUGOHd(A
Const ZHENGLI As String = DBLSPACE & " XXXXXXX" (b|#n|~?YL
Const ALLCLEAR As String = DBLSPACE & "该工作簿中的工作表密码保护已全部解除!!" & DBLSPACE & "请记得另保存" _ lf8xL9v
& DBLSPACE & "注意：不要用在不当地方，要尊重他人的劳动成果！" qG^_c;l6a
Const MSGNOPWORDS1 As String = "该文件工作表中没有加密" WW3
B
Const MSGNOPWORDS2 As String = "该文件工作表中没有加密2" !~d'{ sy6
Const MSGTAKETIME As String = "解密需花费一定时间,请耐心等候!" & DBLSPACE & "按确定开始破解!" Xb+3Xn0}&8
Const MSGPWORDFOUND1 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _ p!GZCf,
"如果该文件工作表有不同密码,将搜索下一组密码并修改清除" (zm Na}-
Const MSGPWORDFOUND2 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _ MOyT< $
"如果该文件工作表有不同密码,将搜索下一组密码并解除" n{{ P 3f
Const MSGONLYONE As String = "确保为唯一的?" hrT%XJl
Dim w1 As Worksheet, w2 As Worksheet W^(Iw%ek
Dim i As Integer, j As Integer, k As Integer, l As Integer DVzssP g
Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer o
PaZ
Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer [tm[,VfA^
Dim PWord1 As String \[T{M!s
Dim ShTag As Boolean, WinTag As Boolean 966<I56+
Application.ScreenUpdating = False .Qfnd#
With ActiveWorkbook JmjxGcG
WinTag = .ProtectStructure Or .ProtectWindows U"B.:C2
End With WFj*nS^~l
ShTag = False Vr\Q`H.
For Each w1 In Worksheets DoG%T(M!a9
ShTag = ShTag Or w1.ProtectContents va>"#;37
Next w1 ,F}r@
If Not ShTag And Not WinTag Then L *{Q jH
MsgBox MSGNOPWORDS1, vbInformation, HEADER &Y=.D:z<
Exit Sub ru(J 5+H
End If 3`rIV*&_{
MsgBox MSGTAKETIME, vbInformation, HEADER SK JW%(|3
If Not WinTag Then ? {j@6,
Else ~BQV]BJ7
On Error Resume Next N<"`ShCNM
Do 'dummy do loop &9@gm --b:
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 E&9!1!B
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 K6(.K EW
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 leIy|K>\m
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 qwP $~Bj
With ActiveWorkbook bqjr 0A7{
.Unprotect Chr(i) & Chr(j) & Chr(k) & _ &>V/X{>$`K
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ ,|iy1yg(
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) !3HsI| $<G
If .ProtectStructure = False And _ <Cr8V'c
.ProtectWindows = False Then 7(@(Hm
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ L"^. 0*X/d
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ WQ.i$ID/
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) A: c]1
MsgBox Application.Substitute(MSGPWORDFOUND1, _ L1F###c
"$$", PWord1), vbInformation, HEADER :;_# 5
Exit Do 'Bypass all for...nexts g 9|qbKQ:[
End If u0'i!@795
End With cdN/Qy
Next: Next: Next: Next: Next: Next UnjNR[=
Next: Next: Next: Next: Next: Next [Gf{f\O
Loop Until True `+^sW#ki
On Error GoTo 0 d|3o/ @k
End If 4
iKR{P6
If WinTag And Not ShTag Then + l.|kkZ?
MsgBox MSGONLYONE, vbInformation, HEADER #~1wv^
Exit Sub (h|ch#
End If yXXvs'$R \
On Error Resume Next j Ii[
For Each w1 In Worksheets JE9>8+
'Attempt clearance with PWord1 O8$~*NFJf
w1.Unprotect PWord1 wlL8X7+:
Next w1
Ft$^x- d
On Error GoTo 0 X/wmKi
ShTag = False '&)D>@g
For Each w1 In Worksheets lDlj+fK
'Checks for all clear ShTag triggered to 1 if not. QnP{$rT
ShTag = ShTag Or w1.ProtectContents N GSS:
Next w1 L^jaBl
If ShTag Then !Z-9tYO
For Each w1 In Worksheets Dh?vU~v(6
With w1 u/#&0_
P
If .ProtectContents Then 9iK&f\#5 H
On Error Resume Next X
[!X>w&z|
Do 'Dummy do loop ,,}s K
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 `11#J;[@G
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 mw Z'=H
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 wH#-mu#Yl<
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 7y;u} 1
.Unprotect Chr(i) & Chr(j) & Chr(k) & _
N)P((>S;
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ yIa[y Jq
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) a! ?.F_T9A
If Not .ProtectContents Then '5V^}/
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ K@*rVor{
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ w`0)x5
TGR
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) +Tp%5+E
MsgBox Application.Substitute(MSGPWORDFOUND2, _ ]DU61Z"v?b
"$$", PWord1), vbInformation, HEADER k}-]W@UCa?
'leverage finding Pword by trying on other sheets S{ey@ X(
For Each w2 In Worksheets ]xI?,('_m
w2.Unprotect PWord1 :Dt\:`(r'
Next w2 PC[cHgSYU
Exit Do 'Bypass all for...nexts &!6DC 5
End If gj Q=8 &i
Next: Next: Next: Next: Next: Next fZ{&dslg
Next: Next: Next: Next: Next: Next []r T? -
Loop Until True <g*.p@o
On Error GoTo 0 ru DP 529;
End If 6I5o2i
End With bz$Qk;m=H
Next w1 OFIMi ^@
End If Li ij{ahm
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK & ZHENGLI, vbInformation, HEADER y 3IA '
End Sub /4^G 34
