ExcelVBA工程密码破解程序

1、ExcelVBA工程密码破解程序2008-08-29 21:06新建一个Excel工作簿,Alt+F11 打开VBA编辑器,新建一个模块,复制以下代 码,注意如提示变量未定义 ,则把 Option Explicit 行删除即可 ,经测试已经通过 .'移除 VBA 编码保护Sub MoveProtect()Dim FileName As StringFileName = Application.GetOpenFilename("Excel文件( *.xls &*.xla ),*.xls;*.xla", , "VBA 破解")If FileN

2、ame = CStr(False) ThenExit SubElseVBAPassword FileName, FalseEnd IfEnd Sub'设置 VBA 编码保护Sub SetProtect()Dim FileName As StringFileName = Application.GetOpenFilename("Excel文件( *.xls &*.xla ),*.xls;*.xla", , "VBA 破解")If FileName = CStr(False) ThenExit SubElseVBAPassword FileN

3、ame, TrueEnd IfEnd SubPrivate Function VBAPassword(FileName As String, Optional ProtectAs Boolean = False)If Dir(FileName) = "" ThenExit FunctionElseFileCopy FileName, FileName & ".bak"End IfDim GetData As String * 5Open FileName For Binary As #1Dim CMGs As LongDim DPBo As Lo

4、ngFor i = 1 To LOF(1)Get #1, i, GetDataIf GetData = "CMG=""" Then CMGs = iIf GetData = "Host" Then DPBo = i - 2: Exit ForNextIf CMGs = 0 ThenMsgBox " 请先对 VBA 编码设置一个保护密码 .", 32, " 提示 " Exit FunctionEnd IfIf Protect = False ThenDim St As String * 2Dim

5、s20 As String * 1' 取得一个 0D0A 十六进制字串Get #1, CMGs - 2, St' 取得一个 20 十六制字串Get #1, DPBo + 16, s20'替换加密部份机码For i = CMGs To DPBo Step 2Put #1, i, StNext'加入不配对符号If （DPBo - CMGs） Mod 2 <> 0 ThenPut #1, DPBo + 1, s20End IfMsgBox " 文件解密成功 ", 32, " 提示"ElseDim MMs As Str

6、ing * 5MMs = "DPB="""Put #1, CMGs, MMsMsgBox " 对文件特殊加密成功 ", 32, "提示"End IfClose #1End FunctionExcel VBA密码破解工具（VBA实现）2007-10-13 08:00使用 UltreEdit 之类的十六进制编辑程序打开 .XLS 文件，在文本模式下查找 “Host Extender Info”（也可只查 Host） ，切换到十六进制模式，将前面的“DBA "XXXXXXX.”的 DBP关键字改成 CBP 将“

7、 GC= "XXXXXXX”的 GC 关键字改成CC使Excel不能识别此二项！存盘即可！ ！ 用Excel打开此文件，忽略错误提示，进入 VBA编辑器，嘿嘿，密码没有了！做 一次存盘操作即可修复错误提示。Access的VBA工程密码采用无法破解!在很多地方我都说过，Excel VBA的工程密码是很脆弱的，其实吧里很早就有一 篇这样的贴子，我也将其整理为加载宏不过还是有很多朋友在问：）。现将主程 序的源代码也整理于此。如果不懂VBA的朋友，也可以去下载我整理的加载宏（点 击下载，需要注册）。'1> 一段极好的VBA保护密码破解程序测试 WIN98+OFFICE9破解率1

8、00%'2>用以下代码对 VBA加密保护后用offkey 6.5-7.0及Advaneed VBA PASSWORDRecovery 专业版均无法破解出保护程式码的密码'移除VBA编码保护Sub MoveProtect()Dim FileName As StringFileName = APPlication.GetOPenFilename("Excel文件( *.xls &*.xla ),*.xls;*.xla", , "VBA破解")If FileName = CStr(False) ThenExit SubElseVB

9、APassword FileName, FalseEnd IfEnd Sub'设置VBA编码保护Sub SetProtect()Dim FileName As StringFileName = APPlication.GetOPenFilename("Excel文件( *.xls &*.xla ),*.xls;*.xla", , "VBA破解")If FileName = CStr(False) ThenExit SubElseVBAPassword FileName, TrueEnd IfEnd SubPrivate Function

10、VBAPassword(FileName As String, OPtional Protect AsBoolean = False)If Dir(FileName) = "" ThenExit FunctionElseFileCoPy FileName, FileName & ".bak"End IfDim GetData As String * 5OPen FileName For Binary As #1Dim CMGs As LongDim DPBo As LongFor i = 1 To LOF(1)Get #1, i, GetData

11、If GetData = "CMG=""" Then CMGs = iIf GetData = "Host" Then DPBo = i - 2: Exit For Next提示"If CMGs = 0 ThenMsgBox "请先对VBA编码设置一个保护密码 ",32," Exit FunctionEnd IfIf Protect = False ThenDim St As String * 2Dim s20 As String * 1'取得一个0D0A十六进制字串Get #1, CM

12、Gs - 2, St' 取得一个 20 十六制字串Get #1, DPBo + 16, s20' 替换加密部份机码For i = CMGs To DPBo Step 2 Put #1, i, StNext' 加入不配对符号If (DPBo - CMGs) Mod 2 <> 0 ThenPut #1, DPBo + 1, s20End IfMsgBox " 文件解密成功", 32, "提示"ElseDim MMs As String * 5MMs = "DPB="""Put #1,

13、 CMGs, MMsMsgBox " 对文件特殊加密成功 ",32, " 提示"End IfClose #1End FunctionOption Explicit'移除 VBA? 保 ?Sub MoveProtect()Dim FileName As StringFileName = Application.GetOpenFilename("Excel 文件( *.xls & *.xla ),*.xls;*.xla", , "VBA 破解 ")If FileName = CStr(False) Th

14、enExit SubElseVBAPassword FileName, FalseEnd IfEnd Sub'?置 VBA? 保 ?Sub SetProtect()Dim FileName As StringFileName = Application.GetOpenFilename("Excel 文件( *.xls & *.xla ),*.xls;*.xla", , "VBA 破解 ")If FileName = CStr(False) ThenExit SubElseVBAPassword FileName, TrueEnd IfEn

15、d SubPrivate Function VBAPassword(FileName As String, Optional Protect As Boolean = False)Dim i As IntegerOn Error Resume NextIf Dir(FileName) = "" ThenExit FunctionElseFileCopy FileName, FileName & "_" & Format(Date, "YYYYMMDD") & Format(Time, "hhmmss&

16、quot;) & ".bak"If Err.Number = "55" ThenMsgBox "指定開疗去歹。閉"Exit FunctionEnd IfEnd IfDim GetData As String * 5Open FileName For Binary As #1Dim CMGs As LongDim DPBo As LongFor i = 1 To LOF(1)Get #1, i, GetDataIf GetData = "CMG=""" Then CMGs = iIf Ge

17、tData = "Host" Then DPBo = i - 2: Exit ForNextIf CMGs = 0 ThenMsgBox " S Excels、VBA設定", 32,"提示”Exit FunctionEnd IfIf Protect = False ThenDim St As String * 2Dim s20 As String * 1'取得一个 0D0A 十六 ?制字串Get #1, CMGs - 2, St'取得一个 20 十六制字串Get #1, DPBo + 16, s20'替 ?加密部 ?机?

18、For i = CMGs To DPBo Step 2Put #1, i, StNext'加入不配 ?符号If (DPBo - CMGs) Mod 2 <> 0 ThenPut #1, DPBo + 1, s20End IfMsgBox "VBA削除 LL!",32,"提示”ElseDim MMs As String * 5MMs = "DPB="""Put #1, CMGs, MMsMsgBox "VBA追加L去 L尢！",32,"提示”End IfClose #1End

19、FunctionExcel VBA 工程密码破解程序 ( 绝对可以破解 )2007-06-24 11:28 新建一个 Excel 工作 簿,Alt+F11打开VBA编辑器，新建一个模块 ，复制以下代码，注意如提示变量未定义 ，则把 Option Explicit 行删除即可 ,经测试已经通过 .'移除 VBA 编码保护Sub MoveProtect()Dim FileName As StringFileName = Application.GetOpenFilename("Excel 文件( *.xls & *.xla ),*.xls;*.xla", , &

20、quot;VBA 破解 ")If FileName = CStr(False) ThenExit SubElseVBAPassword FileName, FalseEnd IfEnd Sub'设置 VBA 编码保护Sub SetProtect()Dim FileName As StringFileName = Application.GetOpenFilename("Excel 文件( *.xls & *.xla ),*.xls;*.xla", , "VBA 破解 ")If FileName = CStr(False) The

21、nExit SubElseVBAPassword FileName, TrueEnd IfEnd SubPrivate Function VBAPassword(FileName As String, Optional Protect As Boolean = False)If Dir(FileName) = "" ThenExit FunctionElseFileCopy FileName, FileName & ".bak"End IfDim GetData As String * 5Open FileName For Binary As #1Dim CMGs As LongDim DPBo As LongFor i = 1 To LOF(1)Get #