使用VBA破解Excel电子表格密码

Question

我尝试编写一个vba 密码破解器代码，类似于我用来破解 Excel 表密码的代码但我不确定我是否正确 - 当我尝试此代码时，它提示我输入密码但没有密码已在文本输入框中输入。

请指出我做错了什么。

谢谢

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

Answer 1

您的代码未正确执行的原因是您试图在受密码保护的 execel 文件上执行宏，这是不允许的。这是因为在输入密码之前宏不会在 Excel 工作簿上执行 - 因此在执行宏代码之前会提示输入密码。

这篇 SO 文章也对此进行了更详细的解释：Excel VBA - Automatically Input Password

编辑

2003 年

---

如果您尝试访问工作簿，而不是工作表，则在 2003 版及更早版本中有多种方法。快速浏览后，这个 blogspot Code Samples 条目似乎有一个用于取消保护 2003 工作簿的工作版本。

此外，在相关说明中，如果您进一步退后并尝试解锁 VBA 项目，此SO article 似乎可以充分解决该问题。

2007 年

---

如果您只是想“蛮力”解除对客户工作簿的保护，一位名叫 Jason 的绅士有outlined such a process in his blog。

---

Answer 2

我在 Excel-2013 中成功地在 Excel 2003 中创建的受密码保护的工作簿上执行了此脚本。

遵循以下步骤：

开发者 --> 录制宏（给一个名字，然后点击）

宏 --> 将您创建的宏用于编辑。

用下面的整个函数替换宏：

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

Answer 3

您似乎正在尝试使用密码解锁工作簿以打开它？

您绝对不应该为此使用 Sendkeys。您应该只将 sendkeys 用作最后的手段。

为避免冲突，请将您的代码放在另一个工作簿中，而不是使用 sendkeys：

Workbooks.Open Filename:="C:\passtest.xls", Password:=password

如果工作簿已经打开并且工作簿受到保护或使用工作表或图表：

[object].Unprotect password

其中 [object] 是对您要取消保护的内容的引用。

如果您尝试解锁 vba 代码，请关注 JimmyPena 的评论

Here's a reference 用于使用与您的代码相似的代码来解锁活动工作表的人。

Answer 4

也许有帮助？

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