EXCEL2007工作表保护密码破解

1.EXCEL工作表保护密码破解宏撤销保护图文教程

你好，这是我遇到类似问题时，上网找的。如果你遇到类似问题，也可以用以下方法进行处理，在这里感谢作者。。。。

1新建宏工具-宏-录制新宏随便输入个名字如hong 点击“确定”按钮

2点击“停止录制”按钮或从菜单“停止录制”宏

3点击工具-宏-宏选择刚才所建的宏然后点击“编辑”按钮

4经过以上会弹出代码编写窗口

5填写代码将下面的代码全部复制必替换原来的字符，填写完毕后关闭该窗口

Public Sub 工作表保护密码破解()

Const DBLSPACE As String = vbNewLine & vbNewLine

Const AUTHORS As String = DBLSPACE & vbNewLine & _

"作者:圣天"

Const HEADER As String = "工作表保护密码破解"

Const VERSION As String = DBLSPACE & "版本 Version 1.1.1"

Const REPBACK As String = DBLSPACE & ""

Const ZHENGLI As String = DBLSPACE & " XXXXXXX" Const ALLCLEAR As String = DBLSPACE & "该工作簿中的工作表密码保护已全部解除!!" & DBLSPACE & "请记得另保存" _

& DBLSPACE & "注意：不要用在不当地方，要尊重他人的劳动成果！"

Const MSGNOPWORDS1 As String = "该文件工作表中没有加密"

Const MSGNOPWORDS2 As String = "该文件工作表中没有加密2"

Const MSGTAKETIME As String = "解密需花费一定时间,请耐心等候!" & DBLSPACE & "按确定开始破解!"

Const MSGPWORDFOUND1 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _

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

Const MSGPWORDFOUND2 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _

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

Const MSGONLYONE As String = "确保为唯一的?"

Dim w1 As Worksheet, w2 As Worksheet

Dim i As Integer, j As Integer, k As Integer, l As Integer

Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer

Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer

Dim PWord1 As String

Dim ShTag As Boolean, WinTag As Boolean

Application.ScreenUpdating = False

With ActiveWorkbook

WinTag = .ProtectStructure Or .ProtectWindows

End With

ShTag = False

For Each w1 In Worksheets

ShTag = ShTag Or w1.ProtectContents

Next w1

If Not ShTag And Not WinTag Then

MsgBox MSGNOPWORDS1, vbInformation, HEADER

Exit Sub

End If

MsgBox MSGTAKETIME, vbInformation, HEADER

If Not WinTag Then

Else

On Error Resume Next

Do 'dummy do loop

For i = 65 To 66: For j = 65 To 66: For k = 65 To 66

For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 With ActiveWorkbook

.Unprotect Chr(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 = False And _

.ProtectWindows = False Then

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)

MsgBox Application.Substitute(MSGPWORDFOUND1, _ "$$", PWord1), vbInformation, HEADER

Exit Do 'Bypass all for...nexts

End If

End With

Next: Next: Next: Next: Next: Next

Next: Next: Next: Next: Next: Next

Loop Until True

On Error GoTo 0

End If

If WinTag And Not ShTag Then

MsgBox MSGONLYONE, vbInformation, HEADER

Exit Sub

End If

On Error Resume Next

For Each w1 In Worksheets

'Attempt clearance with PWord1

w1.Unprotect PWord1

Next w1

On Error GoTo 0

ShTag = False

For Each w1 In Worksheets

'Checks for all clear ShTag triggered to 1 if not. ShTag = ShTag Or w1.ProtectContents

Next w1

If ShTag Then

For Each w1 In Worksheets

With w1

If .ProtectContents Then

On Error Resume Next

Do 'Dummy do loop

For i = 65 To 66: For j = 65 To 66: For k = 65 To 66

For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66

For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66

For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126

.Unprotect Chr(i) & Chr(j) & Chr(k) & _

Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _

Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

If Not .ProtectContents Then

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)

MsgBox Application.Substitute(MSGPWORDFOUND2, _

"$$", PWord1), vbInformation, HEADER

'leverage finding Pword by trying on other sheets

For Each w2 In Worksheets

w2.Unprotect PWord1

Next w2

Exit Do 'Bypass all for...nexts

End If

Next: Next: Next: Next: Next: Next

Next: Next: Next: Next: Next: Next

Loop Until True

On Error GoTo 0

End If

End With

Next w1

End If

MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK & ZHENGLI, vbInformation, HEADER

End Sub

6最后就来执行刚才所建的宏工具-宏-宏点击执行等带小段时间之后就可以看到效果了

2.EXCELvba工程密码破解xlsm（1执行成功，后面就可以不执行）

这种方法实际是避开VBA工程密码验证，即，骗vba编辑器，该密码输入成功，请求放行。

原理不多说了，先将方法公布：

===================================================

1.新建一个工作簿，打开，按ALT+F11，进入vba代码编辑器窗口：

2.新建一个模块，“插入”--“模块”把以下代码复制进模块并保存

---------------------------------------------------------------------------------------

Option Explicit

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _

(Destination As Long, Source As Long, ByVal Length As Long)

Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, _

ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long

Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long

Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _ ByVal lpProcName As String) As Long

Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, _

ByVal pTemplateName As Long, ByVal hWndParent As Long, _

ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer

Dim HookBytes(0 To 5) As Byte

Dim OriginBytes(0 To 5) As Byte

Dim pFunc As Long

Dim Flag As Boolean

Private Function GetPtr(ByVal Value As Long) As Long

'获得函数的地址

GetPtr = Value

End Function

Public Sub RecoverBytes()

'若已经hook,则恢复原API开头的6字节,也就是恢复原来函数的功能

If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6

End Sub

Public Function Hook() As Boolean

Dim TmpBytes(0 To 5) As Byte

Dim p As Long

Dim OriginProtect As Long

Hook = False

'VBE6.dll调用DialogBoxParamA显示VB6INTL.dll资源中的第4070号对话框(就是输入密码的窗口)

'若DialogBoxParamA返回值非0,则VBE会认为密码正确,所以我们要hook DialogBoxParamA函数

pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")

'标准api hook过程之一: 修改内存属性,使其可写

If VirtualProtect(ByVal pFunc, 6, &H40, OriginProtect) <> 0 Then

'标准api hook过程之二: 判断是否已经hook,看看API的第一个字节是否为&H68,

'若是则说明已经Hook

MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6

If TmpBytes(0) <> &H68 Then

'标准api hook过程之三: 保存原函数开头字节,这里是6个字节,以备后面恢复

MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6

'用AddressOf获取MyDialogBoxParam的地址

'因为语法不允许写成p = AddressOf MyDialogBoxParam,这里我们写一个函数

'GetPtr,作用仅仅是返回AddressOf MyDialogBoxParam的值,从而实现将

'MyDialogBoxParam的地址付给p的目的

p = GetPtr(AddressOf MyDialogBoxParam)

'标准api hook过程之四: 组装API入口的新代码

'HookBytes 组成如下汇编

'push MyDialogBoxParam的地址

'ret

'作用是跳转到MyDialogBoxParam函数

HookBytes(0) = &H68

MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4

HookBytes(5) = &HC3

'标准api hook过程之五: 用HookBytes的内容改写API前6个字节

MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6

'设置hook成功标志

Flag = True

Hook = True

End If

End If

End Function

Private Function MyDialogBoxParam(ByVal hInstance As Long, _

ByVal pTemplateName As Long, ByVal hWndParent As Long, _

ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer If pTemplateName = 4070 Then

'有程序调用DialogBoxParamA装入4070号对话框,这里我们直接返回1,让

'VBE以为密码正确了

MyDialogBoxParam = 1

Else

'有程序调用DialogBoxParamA,但装入的不是4070号对话框,这里我们调用

'RecoverBytes函数恢复原来函数的功能,在进行原来的函数

RecoverBytes

MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _

hWndParent, lpDialogFunc, dwInitParam)

'原来的函数执行完毕,再次hook

Hook

End If

End Function

-------------------------------------------------------------------

3.右击sheet1工作表，“查看代码”复制以下代码进去并保存：

-------------------------------------------------------------------

sub 破解()

if hook then

msgbox "破解成功"

end if

end sub

sub 恢复()

RecoverBytes

msgbox "恢复成功"

end sub

------------------------------------

4.到此,一个vba破解程序完成了,回到该工作簿窗口,文件-打开打开需要破解vba工程密码的工作簿.

5.运行"call 破解" 稍后你再双击刚才要解密的VBA工程窗体.是不是如入无人之境啊,工程保护密码形同虚设啊?

6.破解完成后,请右键刚破解的VBA工程,在"查看工程时需要密码"的地方复选框取消选择,OK.完成.

7.完成后别忘了执行"call 恢复",恢复密码保护(恢复程序的密码保护,已被破解的文件不收影响. (请勿用于非法途径)