Public Sub 工作表保护密码破解() x!Z:K5%O
Const DBLSPACE As String = vbNewLine & vbNewLine _ Yb
Eo+
Const AUTHORS As String = DBLSPACE & vbNewLine & _ clPZ d
"作者:XXXXXXX" sR7{ i
Const HEADER As String = "工作表保护密码破解" .y/NudD
Const VERSION As String = DBLSPACE & "版本 Version 1.1.1" [ZL r:2+z
Const REPBACK As String = DBLSPACE & "" ;o~+2Fir
Const ZHENGLI As String = DBLSPACE & " XXXXXXX" 8GF[)z&|P:
Const ALLCLEAR As String = DBLSPACE & "该工作簿中的工作表密码保护已全部解除!!" & DBLSPACE & "请记得另保存" _ 3B!&ow<rt
& DBLSPACE & "注意：不要用在不当地方，要尊重他人的劳动成果！" J4Q)`Y\~
Const MSGNOPWORDS1 As String = "该文件工作表中没有加密" pq/ FLYiv
Const MSGNOPWORDS2 As String = "该文件工作表中没有加密2" $7 1D)* {P
Const MSGTAKETIME As String = "解密需花费一定时间,请耐心等候!" & DBLSPACE & "按确定开始破解!" ;-Y]X(z>
Const MSGPWORDFOUND1 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _ rR),~ @]sL
"如果该文件工作表有不同密码,将搜索下一组密码并修改清除" HJ2]Nz:
Const MSGPWORDFOUND2 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _ `? 9] '
"如果该文件工作表有不同密码,将搜索下一组密码并解除" "w:\@Jwu(
Const MSGONLYONE As String = "确保为唯一的?" r{Qs9
Dim w1 As Worksheet, w2 As Worksheet W<cW;mO
Dim i As Integer, j As Integer, k As Integer, l As Integer )7Ho n
Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer [0**&.obz
Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer 886 ('
Dim PWord1 As String 1p Ymtr
Dim ShTag As Boolean, WinTag As Boolean L.I}-n
Application.ScreenUpdating = False <{-(\>f!9
With ActiveWorkbook NIWI6qCw
WinTag = .ProtectStructure Or .ProtectWindows e"v[)b++Y
End With LX(iuf+l
ShTag = False aPY>fy^8D
For Each w1 In Worksheets c'TiWZP~
ShTag = ShTag Or w1.ProtectContents %%-U .
Next w1 1drqWI~
If Not ShTag And Not WinTag Then ( > +k 3
MsgBox MSGNOPWORDS1, vbInformation, HEADER ^w&5@3d
Exit Sub PJSDY1T
End If 2]_4&mU
MsgBox MSGTAKETIME, vbInformation, HEADER }] n>A
If Not WinTag Then m_r@t*
Else Up!ZCZ$RC
On Error Resume Next }jyS\drJ
Do 'dummy do loop Im' :sJ31
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 f!uA$uL c
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 3 -_U-:2"
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 N,sqr k]
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 &"r==A?
With ActiveWorkbook z6L >!=
.Unprotect Chr(i) & Chr(j) & Chr(k) & _ W O+?gu
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ fn?6%q,!ls
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) "M5ro$qZ}
If .ProtectStructure = False And _ Ls$g-k%c@Q
.ProtectWindows = False Then 5.C[)`_
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ C k/_UY|
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ _/z)&0DO
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
;f ;*Q>!
MsgBox Application.Substitute(MSGPWORDFOUND1, _ 0,L$x*Nj5
"$$", PWord1), vbInformation, HEADER WV !kA_
Exit Do 'Bypass all for...nexts q _T?G e
End If wCC~tuTpr
End With iuU3*yyn
Next: Next: Next: Next: Next: Next 3 q.[ -.q
Next: Next: Next: Next: Next: Next Fgc:6<MGM
Loop Until True # 1qVFU
On Error GoTo 0 oX:1 qJrC
End If Z,8+@
If WinTag And Not ShTag Then VATXsD
MsgBox MSGONLYONE, vbInformation, HEADER W_f "Gk
Exit Sub :zn ?<(sQ
End If C}8e<[} )
On Error Resume Next q$u\
q.
For Each w1 In Worksheets (fk, 80
'Attempt clearance with PWord1 yZ(Nv $[5
w1.Unprotect PWord1 K+\ 0}qn
Next w1 ]\9B?W(#
On Error GoTo 0 \dxW44sM
ShTag = False ,TfI
For Each w1 In Worksheets {GH `V}Ob
'Checks for all clear ShTag triggered to 1 if not. HBga'xJ
ShTag = ShTag Or w1.ProtectContents ,d [b"]Zy
Next w1 +O!M>
If ShTag Then fFTvf0j
For Each w1 In Worksheets <cfH '~
With w1 j2{,1h j
If .ProtectContents Then {, *Y
On Error Resume Next 2Fp]S
a
Do 'Dummy do loop O"s`-OM;n
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 ^s(X VVA
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 LN3dp?;_{
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 84oW
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 |>o0d~s
.Unprotect Chr(i) & Chr(j) & Chr(k) & _ "/K&qj
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ <} Wy;!L
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 'B<qG<>
If Not .ProtectContents Then n Xe K,C
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ tU2t o V
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ b mq XP
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) ";Ig %]
MsgBox Application.Substitute(MSGPWORDFOUND2, _ feq6!k7
"$$", PWord1), vbInformation, HEADER ':R3._tw\
'leverage finding Pword by trying on other sheets ?D^,K`wY=B
For Each w2 In Worksheets \|>` z,;
w2.Unprotect PWord1 n.qxx zEN
Next w2 &F*QYz[
Exit Do 'Bypass all for...nexts uSQ>oi]
End If a$ ! {Tob2
Next: Next: Next: Next: Next: Next 5bznM[%xO
Next: Next: Next: Next: Next: Next ]{6yS9_tuI
Loop Until True ~G ^}2#5
On Error GoTo 0 T# _n-b>
End If eN?P) ,
End With J)yy}[Fx
Next w1 :iNAXy
End If !%\To (r[
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK & ZHENGLI, vbInformation, HEADER Q3O . <9S
End Sub SnF[mN'
