Public Sub 工作表保护密码破解() Y- UXr8
Const DBLSPACE As String = vbNewLine & vbNewLine 7nm'v'\u+V
Const AUTHORS As String = DBLSPACE & vbNewLine & _ 5JHWt<n{P
"作者:XXXXXXX" b wM?DY
Const HEADER As String = "工作表保护密码破解" @XJ#oxM^
Const VERSION As String = DBLSPACE & "版本 Version 1.1.1" y8_$YA/g
Const REPBACK As String = DBLSPACE & "" # c!rx%8I
Const ZHENGLI As String = DBLSPACE & " XXXXXXX" 4O{G^;
Const ALLCLEAR As String = DBLSPACE & "该工作簿中的工作表密码保护已全部解除!!" & DBLSPACE & "请记得另保存" _ T>f6V 5
& DBLSPACE & "注意：不要用在不当地方，要尊重他人的劳动成果！" Ngj&1Ta&[
Const MSGNOPWORDS1 As String = "该文件工作表中没有加密" 6P3h 955c
Const MSGNOPWORDS2 As String = "该文件工作表中没有加密2" |1GOm=GNK
Const MSGTAKETIME As String = "解密需花费一定时间,请耐心等候!" & DBLSPACE & "按确定开始破解!" 2X<%BFsE
Const MSGPWORDFOUND1 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _ k".kbwcaF
"如果该文件工作表有不同密码,将搜索下一组密码并修改清除" VKkvf"X
Const MSGPWORDFOUND2 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _ MuJP.]5>`
"如果该文件工作表有不同密码,将搜索下一组密码并解除" |Fz ^(US
Const MSGONLYONE As String = "确保为唯一的?" /GVjesN
Dim w1 As Worksheet, w2 As Worksheet )=#e*1!b
Dim i As Integer, j As Integer, k As Integer, l As Integer e|?eY)_
Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer )s,LFIy<A
Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer l\F71pwSI
Dim PWord1 As String #dKy{Q3he
Dim ShTag As Boolean, WinTag As Boolean 42~.N =2
Application.ScreenUpdating = False 3&>0'h
With ActiveWorkbook N>Ih2>8t
WinTag = .ProtectStructure Or .ProtectWindows s7afj t
End With Lb)rloca
ShTag = False dB6['z)2
For Each w1 In Worksheets ,PmUl=
ShTag = ShTag Or w1.ProtectContents r<'DS9m
Next w1 ,] :Gn5~
If Not ShTag And Not WinTag Then &<x .D]FA]
MsgBox MSGNOPWORDS1, vbInformation, HEADER `m#-J;la
Exit Sub p^|6 / b
End If NT0n [o^
MsgBox MSGTAKETIME, vbInformation, HEADER F^$;hMh%
If Not WinTag Then ?2l `%l5(
Else 6I: 6+n
On Error Resume Next ?"*JV1 9
Do 'dummy do loop 9/! 1J
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 y>.t[*zT
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 cF 4 ,dnI
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 7Q]c=i cg
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 x!fG%o~h
With ActiveWorkbook ~Th,<w*o
.Unprotect Chr(i) & Chr(j) & Chr(k) & _ e
pp04~
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ ]Zt ]wnL+
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 1
_Oc1RM
If .ProtectStructure = False And _ 0PqI^|!
.ProtectWindows = False Then )=sbrCl,C/
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ #bBh. ^
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ rf-yUH]&S
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) #D/*< :q5
MsgBox Application.Substitute(MSGPWORDFOUND1, _ `3 i<jZMG
"$$", PWord1), vbInformation, HEADER [zBi*%5O
Exit Do 'Bypass all for...nexts ' B{FRK
End If h}! 9?:E
End With {aN pk,n
Next: Next: Next: Next: Next: Next 8q%y(e
Next: Next: Next: Next: Next: Next ,,BP}f+l$
Loop Until True nj0sh"~+
On Error GoTo 0 8 eK 8-R$
End If ~5`oNa
If WinTag And Not ShTag Then ,%
Qh S5e
MsgBox MSGONLYONE, vbInformation, HEADER Db<#gH
Exit Sub En1LGi4#
End If }^iqhUvT F
On Error Resume Next .=9WY_@SZ
For Each w1 In Worksheets $:%E<j 4Dn
'Attempt clearance with PWord1 =qc+sMo
w1.Unprotect PWord1 hO&b\#@~
Next w1 SF&2a(~s
On Error GoTo 0 n8F~! |lQ0
ShTag = False PBnH#zm
For Each w1 In Worksheets ;<N:! $p
'Checks for all clear ShTag triggered to 1 if not. ?WHf%Ie2(
ShTag = ShTag Or w1.ProtectContents "5Y6.$Cuf!
Next w1 'Gqv` rq&
If ShTag Then &n
)MGg1%
For Each w1 In Worksheets Bp_R"DS7A
With w1 G/N c@XG\
If .ProtectContents Then r":anR( ;
On Error Resume Next p d#Sn+&rf
Do 'Dummy do loop ' Zp{
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 chKK9SC+|
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 w^ut,`yW R
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 UL-_z ++G
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 ' {UKO7
.Unprotect Chr(i) & Chr(j) & Chr(k) & _ t|eH'"N%o
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ cu($mjC@T
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 5\MC5us 3
If Not .ProtectContents Then sde>LZet/
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ VJqk0w+
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ A$3Rbn}"
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) gr SF}y!3
MsgBox Application.Substitute(MSGPWORDFOUND2, _ @]vY[O!&;
"$$", PWord1), vbInformation, HEADER xy[#LX)RW
'leverage finding Pword by trying on other sheets +ZM,E8
For Each w2 In Worksheets [K.1 X=O}
w2.Unprotect PWord1 q:/df]Ntt
Next w2 \O;2^
Exit Do 'Bypass all for...nexts ?:J_+? {E
End If *$ g!/,
Next: Next: Next: Next: Next: Next !Fp %2gt|
Next: Next: Next: Next: Next: Next d(o=)!p
Loop Until True ##=$ $1Ki
On Error GoTo 0 IgG[Pr'D
End If )Q'E^[Ua
End With "vSKj/]
Next w1 +ODua@ULFB
End If x{SlJ%V
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK & ZHENGLI, vbInformation, HEADER }I&.xzJ
End Sub Mg.%&vH\
