Public Sub 工作表保护密码破解() !Qzp!k9d
Const DBLSPACE As String = vbNewLine & vbNewLine yE9.]j
Const AUTHORS As String = DBLSPACE & vbNewLine & _ p>O< "X@
"作者:XXXXXXX" rB?cm]G=
Const HEADER As String = "工作表保护密码破解" nGd
Const VERSION As String = DBLSPACE & "版本 Version 1.1.1" AAY UXY!
Const REPBACK As String = DBLSPACE & "" EC&,0i4n:
Const ZHENGLI As String = DBLSPACE & " XXXXXXX" -y.AJ~ T
Const ALLCLEAR As String = DBLSPACE & "该工作簿中的工作表密码保护已全部解除!!" & DBLSPACE & "请记得另保存" _ 5/ju
it
& DBLSPACE & "注意：不要用在不当地方，要尊重他人的劳动成果！" n "Vd"}sU.
Const MSGNOPWORDS1 As String = "该文件工作表中没有加密" 1hS~!r'qqv
Const MSGNOPWORDS2 As String = "该文件工作表中没有加密2" Cw5K*
Const MSGTAKETIME As String = "解密需花费一定时间,请耐心等候!" & DBLSPACE & "按确定开始破解!" 0M98y!A 5^
Const MSGPWORDFOUND1 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _ h'KtG<+
"如果该文件工作表有不同密码,将搜索下一组密码并修改清除" tY=TY{ RY
Const MSGPWORDFOUND2 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _ Zw{tuO7}K
"如果该文件工作表有不同密码,将搜索下一组密码并解除" jy2nn:1#^
Const MSGONLYONE As String = "确保为唯一的?" LTc t0Gh
Dim w1 As Worksheet, w2 As Worksheet 7# 3)&"j
Dim i As Integer, j As Integer, k As Integer, l As Integer fC|u
Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer ~ }22 Dvo
Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer aB'@8[]z
Dim PWord1 As String #Q7$I.O]
Dim ShTag As Boolean, WinTag As Boolean g AP}KR#T
Application.ScreenUpdating = False Ti'kn{
Zv
With ActiveWorkbook vD vGT <d
WinTag = .ProtectStructure Or .ProtectWindows Y1\vt+`O
End With 7k|(5P;
ShTag = False F
k;su,]_
For Each w1 In Worksheets J7vpCw2ni
ShTag = ShTag Or w1.ProtectContents [+z:^a1?V
Next w1 q:^Cw8
If Not ShTag And Not WinTag Then Y cpO;md
MsgBox MSGNOPWORDS1, vbInformation, HEADER R2W_/fs G
Exit Sub o+TZUMm
End If Z+(V \
MsgBox MSGTAKETIME, vbInformation, HEADER &J:)*EjVl5
If Not WinTag Then |lV9?#!
Else eS:e#> (
On Error Resume Next [^~9wFNtd
Do 'dummy do loop 6QQ oHYtZ
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 F JhVbAMd
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 C|LQYz-{
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 z?[DW*
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 v19`7qgR(
With ActiveWorkbook {m:R v&T
.Unprotect Chr(i) & Chr(j) & Chr(k) & _ a0\UL"z#+
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ kELyD(^P`
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Hc|U @G
If .ProtectStructure = False And _ #" -^;Z
.ProtectWindows = False Then )n@ 3@NV
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ ]5/U}Um
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ rK|&u
v*b
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) vy2aNUmt
MsgBox Application.Substitute(MSGPWORDFOUND1, _ =]"|x7'!
"$$", PWord1), vbInformation, HEADER (=V[tI+Ngt
Exit Do 'Bypass all for...nexts mC(t;{
End If $t'I*k^N
End With l&xD3u^G
Next: Next: Next: Next: Next: Next 8-YrmP2k
Next: Next: Next: Next: Next: Next "\?G
Loop Until True u _=y,~s
On Error GoTo 0 T]-~?;Jh8
End If pUG fm
If WinTag And Not ShTag Then A"iD4Q
MsgBox MSGONLYONE, vbInformation, HEADER >]8.xk Qq
Exit Sub ;NeEgqW "
End If !5!$h` g
On Error Resume Next tdF[2@?+
For Each w1 In Worksheets
d2yHfl]3
'Attempt clearance with PWord1 (`?
snMc
w1.Unprotect PWord1 v=-3 ,C
Next w1 ABmDSV5i
On Error GoTo 0 @ibPL+~-_
ShTag = False b)^ZiRW``
For Each w1 In Worksheets j)6B^!
'Checks for all clear ShTag triggered to 1 if not. uA`PZ|
ShTag = ShTag Or w1.ProtectContents "m;]6B."
Next w1 >I~z7 JS
If ShTag Then 3eP0v
For Each w1 In Worksheets TFDCo_>o
With w1 G<6grd5 PP
If .ProtectContents Then 0(9@GIT
On Error Resume Next dU^<7 K:S
Do 'Dummy do loop G11.6]?Gg
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 jZ,[{Z(N
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 eE`1;13;
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 X`QW(rq
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 U*"cf>dB(
.Unprotect Chr(i) & Chr(j) & Chr(k) & _ ptni'W3
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ :P~&
b P
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 4@iJ |l
If Not .ProtectContents Then )pn 7DIXG
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ ;Jn0 e:x`E
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ `G0rF\[
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) `R52{B#&/
MsgBox Application.Substitute(MSGPWORDFOUND2, _ 5=h'!|iY
"$$", PWord1), vbInformation, HEADER M2P@ &
'leverage finding Pword by trying on other sheets 6cT~irP
For Each w2 In Worksheets >VU QTg
w2.Unprotect PWord1 Bd~cY/M
Next w2 + >gbZ-S
Exit Do 'Bypass all for...nexts AKC foJ
End If ])j|<W/
Next: Next: Next: Next: Next: Next X >Xp&o
Next: Next: Next: Next: Next: Next K[>@'P}y
Loop Until True C6V&R1" s
On Error GoTo 0 iVi3 :7*
End If ENx@ Ex
End With LLn{2,jfQ
Next w1 #+Yp^6zg
End If @f5@0A\0
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK & ZHENGLI, vbInformation, HEADER ^8oc^LOa~2
End Sub }#W`<,*rL.
