Public Sub 工作表保护密码破解() 1eQ 9(hzF
Const DBLSPACE As String = vbNewLine & vbNewLine s42M[BW]
Const AUTHORS As String = DBLSPACE & vbNewLine & _ jW*| Mu>2
"作者:XXXXXXX" Tw yx(~'&R
Const HEADER As String = "工作表保护密码破解" 84^ '^nd
Const VERSION As String = DBLSPACE & "版本 Version 1.1.1" jZeY^T)f"
Const REPBACK As String = DBLSPACE & "" [2#5;')
Const ZHENGLI As String = DBLSPACE & " XXXXXXX" Nq1la8oQ3
Const ALLCLEAR As String = DBLSPACE & "该工作簿中的工作表密码保护已全部解除!!" & DBLSPACE & "请记得另保存" _ fyP p zA0
& DBLSPACE & "注意：不要用在不当地方，要尊重他人的劳动成果！" !s pp*Q)#\
Const MSGNOPWORDS1 As String = "该文件工作表中没有加密" ' _,/N!-V
Const MSGNOPWORDS2 As String = "该文件工作表中没有加密2" n/#zx:d?
Const MSGTAKETIME As String = "解密需花费一定时间,请耐心等候!" & DBLSPACE & "按确定开始破解!" w naP? |/
Const MSGPWORDFOUND1 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _ n 1MZHa,
"如果该文件工作表有不同密码,将搜索下一组密码并修改清除" 5vs~8|aRo
Const MSGPWORDFOUND2 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _ }&D~P>1
"如果该文件工作表有不同密码,将搜索下一组密码并解除" [
qt
hn[3
Const MSGONLYONE As String = "确保为唯一的?" s. I%[kada
Dim w1 As Worksheet, w2 As Worksheet B.CUk.
Dim i As Integer, j As Integer, k As Integer, l As Integer `v3WJ>Q!N?
Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer Q\Dx/?g!vx
Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer H"czF
Dim PWord1 As String $Llv6<B
Dim ShTag As Boolean, WinTag As Boolean i'9aQi" G
Application.ScreenUpdating = False D ]Q,~Y&'
With ActiveWorkbook >)*'w!
WinTag = .ProtectStructure Or .ProtectWindows s tuj,8
End With n% zW6}
ShTag = False r/zu o6"5
For Each w1 In Worksheets C(zgBk
ShTag = ShTag Or w1.ProtectContents hw! l{yv
Next w1 ap=m5h27
If Not ShTag And Not WinTag Then k7JE{ (Ok
MsgBox MSGNOPWORDS1, vbInformation, HEADER YoyJnl.?u
Exit Sub {y)O ?9q
End If u3 k%
MsgBox MSGTAKETIME, vbInformation, HEADER j8n_:;i*
If Not WinTag Then &_Kb;UVRj
Else ]D?//
On Error Resume Next .4on7<-a
Do 'dummy do loop J1OZG6|e
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 F5UvD [i
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 X`i' U7%I
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 S3#NGBZ/
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 Uytq,3Gj6
With ActiveWorkbook (:9yeP1
.Unprotect Chr(i) & Chr(j) & Chr(k) & _ Mo?eVtZ
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ D4,kGU@
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) <xM$^r)
If .ProtectStructure = False And _ xz2U?)m;x
.ProtectWindows = False Then 6v8HR}iK
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ mGx! {v~i&
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ .EeXq }a[
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) t Gt/=~n9
MsgBox Application.Substitute(MSGPWORDFOUND1, _ g4b -~1[S
"$$", PWord1), vbInformation, HEADER /`(Kbwh
Exit Do 'Bypass all for...nexts s18o,Zs'
End If VB>KT(n-b
End With =KQQS6
Next: Next: Next: Next: Next: Next ZEY="pf
Next: Next: Next: Next: Next: Next y 8} fj=
Loop Until True V{ !fa g
On Error GoTo 0 cr GFU?8
End If 7AwV4r*:
If WinTag And Not ShTag Then ?%RAX CK
MsgBox MSGONLYONE, vbInformation, HEADER A:|dY^,:?*
Exit Sub P dgn9
End If % 8c
<C
On Error Resume Next b-*3] gB
For Each w1 In Worksheets wQ1_Q8 :Z
'Attempt clearance with PWord1 hxG= g6:G
w1.Unprotect PWord1 s
P=$>@3
Next w1 2n ]UNC
On Error GoTo 0 Ah^0 FU%!g
ShTag = False pe^hOzVv
For Each w1 In Worksheets ggluQG A
'Checks for all clear ShTag triggered to 1 if not. R Ln sy,
ShTag = ShTag Or w1.ProtectContents R-7.q
Next w1 &d,chb (
If ShTag Then (PVK|Q55y
For Each w1 In Worksheets V+\L@ mz;
With w1 0cYd6u @
If .ProtectContents Then )"( ojh
On Error Resume Next :TU|;(p
Do 'Dummy do loop MmIV Tf4
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 cnJL*{H<2
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 g)Ep'd-w"
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 b5!\"v4c
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 IE;Fu67wi
.Unprotect Chr(i) & Chr(j) & Chr(k) & _ QuF76&)7
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ ceiUpWMu,
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) K &L9Ue
If Not .ProtectContents Then w$5~ 'Cbi
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ $? 'JePC
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ ]V*ku% L0
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) >Xz=E0;^Ua
MsgBox Application.Substitute(MSGPWORDFOUND2, _ qcN{p7=0
"$$", PWord1), vbInformation, HEADER "zN2+X"&
'leverage finding Pword by trying on other sheets ^Rel- =Z$B
For Each w2 In Worksheets ,(1n(FZ
w2.Unprotect PWord1 xXa* d
Next w2 'A^ ;P]y
Exit Do 'Bypass all for...nexts $5( _ U
End If 0LX"<~3j
Next: Next: Next: Next: Next: Next /6?A#%hc
Next: Next: Next: Next: Next: Next XsH(8 -n0
Loop Until True )^Ha?;TS
On Error GoTo 0 D)kh"cK*1
End If 3Jt7IM!9[
End With h;q= <[h\
Next w1 W^o* ^v
End If ,5Vc
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK & ZHENGLI, vbInformation, HEADER uq/z.m
End Sub Y 6NoNc]h
