使用 VBA 破解 Excel 电子表格密码
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/11649064/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Excel spreadsheet password cracking using VBA
提问by codeomnitrix
I tried writing a vbapassword cracker code similar to the code I used to crack Excel sheet's password But I am not sure if I am doing correctly or not - when i tried this code it prompted me for password but no password was entered to the text input box.
我尝试编写一个类似于我用来破解 Excel 工作表密码的代码的vba密码破解器代码但我不确定我是否做得正确 - 当我尝试此代码时，它提示我输入密码但没有在文本中输入密码输入框。
Please suggest what I am doing wrong.
请建议我做错了什么。
Thanks
谢谢
Sub testmacro()
Dim password
Dim a, b, c, d, e, f, g, h, i, j, k, l
SendKeys "^r"
SendKeys "{PGUP}"
For a = 65 To 66
For b = 65 To 66
For c = 65 To 66
For d = 65 To 66
For e = 65 To 66
For f = 65 To 66
For g = 65 To 66
For h = 65 To 66
For i = 65 To 66
For j = 0 To 255
password = Chr(a) & Chr(b) & Chr(c) & Chr(d) & Chr(e) & Chr(f) & Chr(g) & Chr(h) & Chr(i) & Chr(j)
SendKeys "{Enter}", True
MsgBox password
SendKeys password, True
SendKeys "{Enter}", True
On Error GoTo 200
MsgBox password
GoTo 300
200 password = ""
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
300 MsgBox "exited"
End Sub
回答by HymanOrangeLantern
The reason your code is not executing properly is because you are attempting to execute a macro on a password protected execel file, which is not permitted. This is due to the fact that macros will not execute on an excel workbook until the password is entered - thus the prompt for a password before you can execute your macro code.
您的代码未正确执行的原因是您试图在受密码保护的 execel 文件上执行宏，这是不允许的。这是因为在输入密码之前，宏不会在 Excel 工作簿上执行 - 因此在您可以执行宏代码之前提示输入密码。
This SO article explains this as well, with greater detail: Excel VBA - Automatically Input Password
这篇 SO 文章也解释了这一点，更详细：Excel VBA - 自动输入密码
EDIT
编辑
For 2003
2003年
If you are trying to access the workbook, not the worksheet, there are a variety of ways in versions 2003 and earlier. After a quick perusual, this blogspot Code Samplesentry appears to have a working version for unprotecting a 2003 workbook.
如果您尝试访问工作簿，而不是工作表，则在 2003 及更早版本中有多种方法。快速阅读后，这个 blogspot代码示例条目似乎有一个用于取消保护 2003 工作簿的工作版本。
Also, on a related note, if you are stepping back even further and trying to unlock a VBA project, this SO articleappears to adequately address the issue.
此外，在相关说明中，如果您更进一步并尝试解锁 VBA 项目，这篇SO 文章似乎可以充分解决该问题。
For 2007
2007年
If you are simply trying to "brute force" unprotect a client's workbook, a gentleman named Jason has outlined such a process in his blog.
如果您只是想“蛮力”解除对客户工作簿的保护，一位名叫 Jason 的绅士在他的博客中概述了这样一个过程。
回答by rchacko
I successfully executed this script in Excel-2013 on a password protected workbook created in Excel 2003.
我在 Excel-2013 中在 Excel 2003 中创建的受密码保护的工作簿上成功执行了此脚本。
Followed the following steps:
遵循了以下步骤：
Developer --> Record Macro (give a name, then do some clicks)
开发人员 --> 录制宏（指定名称，然后单击）
Macros --> take the macro you created for edit.
宏 --> 使用您创建的宏进行编辑。
Replace the Macro with the whole function below:
用下面的整个函数替换宏：
Sub PasswordBreaker()
'Breaks worksheet password protection.
Dim i As Integer, j As Integer, k As Integer
Dim l As Integer, m As Integer, n As Integer
Dim i1 As Integer, i2 As Integer, i3 As Integer
Dim i4 As Integer, i5 As Integer, i6 As Integer
On Error Resume Next
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
ActiveSheet.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 ActiveSheet.ProtectContents = False Then
MsgBox "One usable password is " & Chr(i) & Chr(j) & _
Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
Exit Sub
End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
End Sub
回答by Daniel
It looks like you're trying to unlock a workbook with a password to open it?
看起来您正在尝试使用密码解锁工作簿以将其打开？
You absolutely should not be using Sendkeysfor that. You should only ever use sendkeys as a last resort.
您绝对不应该为此使用 Sendkeys。您应该只将发送密钥用作最后的手段。
To avoid conflicts, put your code in another workbook and instead of the sendkeys use:
为避免冲突，请将您的代码放在另一个工作簿中，而不是使用发送键：
Workbooks.Open Filename:="C:\passtest.xls", Password:=password
If the workbook is already open and the workbook is protected or a sheet or chart use:
如果工作簿已经打开并且工作簿受到保护或者工作表或图表使用：
[object].Unprotect password
Wherew [object] is a reference to what you are trying to unprotect.
wherew [object] 是对您要取消保护的内容的引用。
If you are trying to unlock the vba code, follow the comment by JimmyPena
如果您正在尝试解锁 vba 代码，请按照 JimmyPena 的评论进行操作
Here's a referencefor someone using similar code to yours for unlocking the active sheet.
这是使用与您的代码类似的代码来解锁活动工作表的人的参考。
回答by wittrup
Maybe of some help?
也许有帮助？
Option Explicit
Const PWDMaxLength = 9
Const MaxTimeInSeconds = 600 ' 10 Minutes
Const PWDWindowName = "Password"
Const TargetFile = "D:\Dropbox\Excel stuff\crack\test.xls"
Const LowerCase = "abcdefghijklmnopqrstuvwxyz???"
Const UpperCase = "ABCDEFGHIJKLMNOPQRSTUVWXYZ???"
Const SpesChars = "+-*@#%=?!_;./"
Const Digits = "0123456789"
Dim CrackAttempt As Long
Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Sub BFOpen()
On Error Resume Next
Application.DisplayAlerts = False
Workbooks.Open Filename:=TargetFile
Application.DisplayAlerts = True
On Error GoTo 0
End Sub
Sub BFCrack()
'On Error Resume Next
Dim lSta, lCur As Long, test, str, PWD As String
lSta = GetTickCount()
PWD = LowerCase & UpperCase & SpesChars & Digits
CrackAttempt = 1
test = InputBox("Insert test string for brutforce if wanted" & vbCrLf & "not more than 5 characters...", "input")
SendKeys "%{TAB}", 100
Do While str <> test Or FindWindow(vbNullString, PWDWindowName) And (Len(str) < PWDMaxLength <> 0 And (lCur / 1000) < MaxTimeInSeconds)
lCur = (GetTickCount() - lSta)
If lCur Mod 250 = 0 Then Application.StatusBar = str & " " & CrackAttempt & " " & lCur
str = GBFS(PWD, CrackAttempt)
If test = "" Then SendKeys str & "{ENTER}", 1000
CrackAttempt = CrackAttempt + 1
Loop
Application.StatusBar = False
If str <> "" Then MsgBox str & " found in " & CStr((GetTickCount() - lSta) / 1000) & " seconds after " & CrackAttempt & " attempts", vbOKOnly + vbInformation, "Result"
On Error GoTo 0
End Sub
Function GBFS(ByVal inp As String, ByVal att As Long) As String
Dim Base, cal As Integer, rmi, res As Long
Base = Len(inp)
If Base < 2 Then Exit Function
rmi = att
Do While rmi > 0
res = Int(rmi / Base)
cal = rmi - (res * Base)
If cal = 0 Then
cal = Base
res = res - 1
End If
GBFS = Mid(inp, cal, 1) & GBFS
rmi = res
Loop
End Function
