EXCEL工作表和VBA密码去除法.docx

EXCEL工作表和VBA密码去除法.docx

《EXCEL工作表和VBA密码去除法.docx》由会员分享，可在线阅读，更多相关《EXCEL工作表和VBA密码去除法.docx（8页珍藏版）》请在冰豆网上搜索。

EXCEL工作表和VBA密码去除法

EXCEL工作表和VBA密码去除法

一、工作表密码破解

PublicSub工作表保护密码破解（）

ConstDBLSPACEAsString=vbNewLine&vbNewLine

ConstAUTHORSAsString=DBLSPACE&vbNewLine&_

"作者:

Neyo"

ConstHEADERAsString="工作表保护密码破解"

ConstVERSIONAsString=DBLSPACE&"版本Version1.1.1"

ConstREPBACKAsString=DBLSPACE&""

ConstZHENGLIAsString=DBLSPACE&"Neyo整理"

ConstALLCLEARAsString=DBLSPACE&"该工作簿中的工作表密码保护已全部解除!

!

"&DBLSPACE&"请记得另保存"_

&DBLSPACE&"注意：

不要用在不当地方，要尊重他人的劳动成果！

"

ConstMSGNOPWORDS1AsString="该文件工作表中没有加密"

ConstMSGNOPWORDS2AsString="该文件工作表中没有加密2"

ConstMSGTAKETIMEAsString="解密需花费一定时间,请耐心等候!

"&DBLSPACE&"按确定开始破解!

"

ConstMSGPWORDFOUND1AsString="密码重新组合为:

"&DBLSPACE&"$$"&DBLSPACE&_

"如果该文件工作表有不同密码,将搜索下一组密码并修改清除"

ConstMSGPWORDFOUND2AsString="密码重新组合为:

"&DBLSPACE&"$$"&DBLSPACE&_

"如果该文件工作表有不同密码,将搜索下一组密码并解除"

ConstMSGONLYONEAsString="确保为唯一的?

"

Dimw1AsWorksheet,w2AsWorksheet

DimiAsInteger,jAsInteger,kAsInteger,lAsInteger

DimmAsInteger,nAsInteger,i1AsInteger,i2AsInteger

Dimi3AsInteger,i4AsInteger,i5AsInteger,i6AsInteger

DimPWord1AsString

DimShTagAsBoolean,WinTagAsBoolean

Application.ScreenUpdating=False

WithActiveWorkbook

WinTag=.ProtectStructureOr.ProtectWindows

EndWith

ShTag=False

ForEachw1InWorksheets

ShTag=ShTagOrw1.ProtectContents

Nextw1

IfNotShTagAndNotWinTagThen

MsgBoxMSGNOPWORDS1,vbInformation,HEADER

ExitSub

EndIf

MsgBoxMSGTAKETIME,vbInformation,HEADER

IfNotWinTagThen

Else

OnErrorResumeNext

Do'dummydoloop

Fori=65To66:

Forj=65To66:

Fork=65To66

Forl=65To66:

Form=65To66:

Fori1=65To66

Fori2=65To66:

Fori3=65To66:

Fori4=65To66

Fori5=65To66:

Fori6=65To66:

Forn=32To126

WithActiveWorkbook

.UnprotectChr（i）&Chr（j）&Chr（k）&_

Chr（l）&Chr（m）&Chr（i1）&Chr（i2）&_

Chr（i3）&Chr（i4）&Chr（i5）&Chr（i6）&Chr（n）

If.ProtectStructure=FalseAnd_

.ProtectWindows=FalseThen

PWord1=Chr（i）&Chr（j）&Chr（k）&Chr（l）&_

Chr（m）&Chr（i1）&Chr（i2）&Chr（i3）&_

Chr（i4）&Chr（i5）&Chr（i6）&Chr（n）

MsgBoxApplication.Substitute（MSGPWORDFOUND1,_

"$$",PWord1）,vbInformation,HEADER

ExitDo'Bypassallfor...nexts

EndIf

EndWith

Next:

Next:

Next:

Next:

Next:

Next

Next:

Next:

Next:

Next:

Next:

Next

LoopUntilTrue

OnErrorGoTo0

EndIf

IfWinTagAndNotShTagThen

MsgBoxMSGONLYONE,vbInformation,HEADER

ExitSub

EndIf

OnErrorResumeNext

ForEachw1InWorksheets

'AttemptclearancewithPWord1

w1.UnprotectPWord1

Nextw1

OnErrorGoTo0

ShTag=False

ForEachw1InWorksheets

'ChecksforallclearShTagtriggeredto1ifnot.

ShTag=ShTagOrw1.ProtectContents

Nextw1

IfShTagThen

ForEachw1InWorksheets

Withw1

If.ProtectContentsThen

OnErrorResumeNext

Do'Dummydoloop

Fori=65To66:

Forj=65To66:

Fork=65To66

Forl=65To66:

Form=65To66:

Fori1=65To66

Fori2=65To66:

Fori3=65To66:

Fori4=65To66

Fori5=65To66:

Fori6=65To66:

Forn=32To126

.UnprotectChr（i）&Chr（j）&Chr（k）&_

Chr（l）&Chr（m）&Chr（i1）&Chr（i2）&Chr（i3）&_

Chr（i4）&Chr（i5）&Chr（i6）&Chr（n）

IfNot.ProtectContentsThen

PWord1=Chr（i）&Chr（j）&Chr（k）&Chr（l）&_

Chr（m）&Chr（i1）&Chr（i2）&Chr（i3）&_

Chr（i4）&Chr（i5）&Chr（i6）&Chr（n）

MsgBoxApplication.Substitute（MSGPWORDFOUND2,_

"$$",PWord1）,vbInformation,HEADER

'leveragefindingPwordbytryingonothersheets

ForEachw2InWorksheets

w2.UnprotectPWord1

Nextw2

ExitDo'Bypassallfor...nexts

EndIf

Next:

Next:

Next:

Next:

Next:

Next

Next:

Next:

Next:

Next:

Next:

Next

LoopUntilTrue

OnErrorGoTo0

EndIf

EndWith

Nextw1

EndIf

MsgBoxALLCLEAR&AUTHORS&VERSION&REPBACK&ZHENGLI,vbInformation,HEADER

EndSub

二、VBA密码破解forExcel2003

在空白excel文档vba里面插入模块，运行此模块

OptionExplicit

ConstLANG_ENGLISHAsInteger=9

TypeCommandLineInfo

NameAsString

ValueAsString

StartPosAsLong

EndType

Submain（）

DimfNameAsString

fName=Application.GetOpenFilename（"Excel文件（xls;xla）,*.xls;*.xla",,"选择要破解的EXCEL2003包含VBA密码的文件"）

IffName="False"ThenExitSub

DimfNewNameAsString

fNewName=MoveProtect（fName）

IfLen（fNewName）Then

IfMsgBox（"转换完成,另存为：

"&vbLf&fNewName&vbLf&"要打开吗？

",vbQuestion+vbYesNo,"完成"）=vbYesThenWorkbooks.OpenfNewName

Else

MsgBox"未发现VBAProject有密码特征字符串",vbInformation,"提示"

EndIf

EndSub

PrivateFunctionMoveProtect（fNameAsString）AsString

DimmyExcelFileDataAsString

DimmyCommandLinesInfo（）AsCommandLineInfo

myExcelFileData=GetFileData（fName）

IfSearchSpecificCommandInfo（myExcelFileData,myCommandLinesInfo）Then

MoveProtect=Write2File（Left（fName,Len（fName）-4）&"_覆盖VBA密码.xls",CoverData（myExcelFileData,myCommandLinesInfo））

EndIf

EndFunction

PrivateFunctionGetFileData（fNameAsString）AsString