ExcelVBA工程密码破解程序.doc

ExcelVBA工程密码破解程序2008-08-29 21:06新建一个Excel工作簿,Alt+F11 打开VBA编辑器,新建一个模块 ,复制以下代码,注意如提示变量未定义,则把Option Explicit行删除即可,经测试已经通过.移除VBA编码保护Sub MoveProtect() Dim FileName As String FileName = Application.GetOpenFilename(Excel文件（*.xls & *.xla）,*.xls;*.xla, , VBA破解) If FileName = CStr(False) Then Exit Sub Else VBAPassword FileName, False End IfEnd Sub设置VBA编码保护Sub SetProtect() Dim FileName As String FileName = Application.GetOpenFilename(Excel文件（*.xls & *.xla）,*.xls;*.xla, , VBA破解) If FileName = CStr(False) Then Exit Sub Else VBAPassword FileName, True End IfEnd SubPrivate Function VBAPassword(FileName As String, Optional Protect As Boolean = False) If Dir(FileName) = Then Exit Function Else FileCopy FileName, FileName & .bak End If Dim GetData As String * 5 Open FileName For Binary As #1 Dim CMGs As Long Dim DPBo As Long For i = 1 To LOF(1) Get #1, i, GetData If GetData = CMG= Then CMGs = i If GetData = Host Then DPBo = i - 2: Exit For Next If CMGs = 0 Then MsgBox 请先对VBA编码设置一个保护密码., 32, 提示 Exit Function End If If Protect = False Then Dim St As String * 2 Dim s20 As String * 1 取得一个0D0A十六进制字串 Get #1, CMGs - 2, St 取得一个20十六制字串 Get #1, DPBo + 16, s20 替换加密部份机码 For i = CMGs To DPBo Step 2 Put #1, i, St Next 加入不配对符号 If (DPBo - CMGs) Mod 2 0 Then Put #1, DPBo + 1, s20 End If MsgBox 文件解密成功., 32, 提示 Else Dim MMs As String * 5 MMs = DPB= Put #1, CMGs, MMs MsgBox 对文件特殊加密成功., 32, 提示 End If Close #1End FunctionExcel VBA密码破解工具（VBA实现）2007-10-13 08:00使用UltreEdit之类的十六进制编辑程序打开.XLS文件，在文本模式下查找“Host Extender Info”(也可只查Host)，切换到十六进制模式，将前面的“DBPXXXXXXX.”的DBP关键字改成CBP，将“GC XXXXXXX.”的GC关键字改成CC，使Excel不能识别此二项！存盘即可！ 用Excel打开此文件，忽略错误提示，进入VBA编辑器，嘿嘿，密码没有了！做一次存盘操作即可修复错误提示。 Access的VBA工程密码采用无法破解！ 在很多地方我都说过，Excel VBA的工程密码是很脆弱的，其实吧里很早就有一篇这样的贴子，我也将其整理为加载宏不过还是有很多朋友在问：）。现将主程序的源代码也整理于此。如果不懂VBA的朋友，也可以去下载我整理的加载宏（点击下载，需要注册）。 1一段极好的VBA保护密码破解程序测试WIN98+OFFICE97破解率100% 2用以下代码对VBA加密保护后用offkey 6.5-7.0及Advanced VBA pASSWORD Recovery专业版均无法破解出保护程式码的密码 移除VBA编码保护Sub MoveProtect() Dim FileName As String FileName = Application.GetOpenFilename(Excel文件（*.xls & *.xla）,*.xls;*.xla, , VBA破解) If FileName = CStr(False) Then Exit Sub Else VBAPassword FileName, False End If End Sub 设置VBA编码保护 Sub SetProtect() Dim FileName As String FileName = Application.GetOpenFilename(Excel文件（*.xls & *.xla）,*.xls;*.xla, , VBA破解) If FileName = CStr(False) Then Exit Sub Else VBAPassword FileName, True End If End Sub Private Function VBAPassword(FileName As String, Optional Protect As Boolean = False) If Dir(FileName) = Then Exit Function Else FileCopy FileName, FileName & .bak End If Dim GetData As String * 5 Open FileName For Binary As #1 Dim CMGs As Long Dim DPBo As Long For i = 1 To LOF(1) Get #1, i, GetData If GetData = CMG= Then CMGs = i If GetData = Host Then DPBo = i - 2: Exit For Next If CMGs = 0 Then MsgBox 请先对VBA编码设置一个保护密码., 32, 提示 Exit Function End If If Protect = False Then Dim St As String * 2 Dim s20 As String * 1 取得一个0D0A十六进制字串 Get #1, CMGs - 2, St 取得一个20十六制字串 Get #1, DPBo + 16, s20 替换加密部份机码 For i = CMGs To DPBo Step 2 Put #1, i, St Next 加入不配对符号 If (DPBo - CMGs) Mod 2 0 Then Put #1, DPBo + 1, s20 End If MsgBox 文件解密成功., 32, 提示 Else Dim MMs As String * 5 MMs = DPB= Put #1, CMGs, MMs MsgBox 对文件特殊加密成功., 32, 提示 End If Close #1 End FunctionOption Explicit移除VBA?保?Sub MoveProtect() Dim FileName As String FileName = Application.GetOpenFilename(Excel文件（*.xls & *.xla）,*.xls;*.xla, , VBA破解) If FileName = CStr(False) Then Exit Sub Else VBAPassword FileName, False End IfEnd Sub?置VBA?保?Sub SetProtect() Dim FileName As String FileName = Application.GetOpenFilename(Excel文件（*.xls & *.xla）,*.xls;*.xla, , VBA破解) If FileName = CStr(False) Then Exit Sub Else VBAPassword FileName, True End IfEnd SubPrivate Function VBAPassword(FileName As String, Optional Protect As Boolean = False) Dim i As Integer On Error Resume Next If Dir(FileName) = Then Exit Function Else FileCopy FileName, FileName & _ & Format(Date, YYYYMMDD) & Format(Time, hhmmss) & .bak If Err.Number = 55 Then MsgBox 指定開。閉。 Exit Function End If End If Dim GetData As String * 5 Open FileName For Binary As #1 Dim CMGs As Long Dim DPBo As Long For i = 1 To LOF(1) Get #1, i, GetData If GetData = CMG= Then CMGs = i If GetData = Host Then DPBo = i - 2: Exit For Next If CMGs = 0 Then MsgBox Excel、VBA設定！, 32, 提示 Exit Function End If If Protect = False Then Dim St As String * 2 Dim s20 As String * 1 取得一个0D0A十六?制字串 Get #1, CMGs - 2, St 取得一个20十六制字串 Get #1, DPBo + 16, s20 替?加密部?机? For i = CMGs To DPBo Step 2 Put #1, i, St Next 加入不配?符号 If (DPBo - CMGs) Mod 2 0 Then Put #1, DPBo + 1, s20 End If MsgBox VBA削除！., 32, 提示 Else Dim MMs As String * 5 MMs = DPB= Put #1, CMGs, MMs MsgBox VBA追加！., 32, 提示 End If Close #1End FunctionExcel VBA工程密码破解程序 (绝对可以破解)2007-06-24 11:28新建一个Excel工作簿,Alt+F11 打开VBA编辑器,新建一个模块 ,复制以下代码,注意如提示变量未定义,则把Option Explicit行删除即可,经测试已经通过.移除VBA编码保护Sub MoveProtect() Dim FileName As String FileName = Application.GetOpenFilename(Excel文件（*.xls & *.xla）,*.xls;*.xla, , VBA破解) If FileName = CStr(False) Then Exit Sub Else VBAPassword FileName, False End IfEnd Sub设置VBA编码保护Sub SetProtect() Dim FileName As String FileName = Application.GetOpenFilename(Excel文件（*.xls & *.xla）,*.xls;*.xla, , VBA破解) If FileName = CStr(False) Then Exit Sub Else VBAPassword FileName, True End IfEnd SubPrivate Function VBAPassword(FileName As String, Optional Protect As Boolean = False) If Dir(FileName) = Then Exit Function Else FileCopy FileName, FileName & .bak End If Dim GetData As String * 5 Open FileName For Binary As #1 Dim CMGs As Lo