使用VBA的Excel电子表格密码破解
我试着写一个类似于我用来破解Excel表单密码的代码的vba密码破解代码但是我不知道我是否正确地执行了操作 – 当我尝试这个代码时，它提示我input密码，但没有input密码input框。
请build议我做错了什么。
谢谢
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 您的代码不正确执行的原因是因为您正试图执行密码保护的execel文件，这是不允许的macros。 这是因为在input密码之前，macros将不会在Excel工作簿上执行 – 因此在执行macros代码之前提示input密码。
这篇文章解释了这一点，更详细的说明： Excel VBA – 自动input密码
编辑
2003年
如果您尝试访问工作簿 ，而不是工作表，则2003版和更早版本中有多种方法。 经过一个简单的例子，这个blogspot Code Samples条目似乎有一个解除2003工作簿的工作版本。
另外，在一个相关的说明中，如果你正在更进一步地尝试解锁一个VBA项目，这篇SO文章似乎能够充分解决这个问题。
2007年
如果你只是试图“暴力破坏”一个客户的工作簿，一个名叫杰森的绅士已经在他的博客中列出了这样一个过程 。
它看起来像你试图用密码解锁工作簿打开它？
你绝对不应该使用Sendkeys 。 你应该只使用sendkeys作为最后的手段。
为避免冲突，请将代码放在另一个工作簿中，而不是使用sendkeys：
Workbooks.Open Filename:="C:\passtest.xls", Password:=password
如果工作簿已经打开并且工作簿受到保护，或者工作表或图表使用：
[object].Unprotect password
其中[对象]是指您要解除保护的内容。
如果您尝试解锁vba代码，请按照JimmyPena发表的评论
以下是使用类似代码解锁活动工作表的人员的参考。
我在Excel 2003中创build的受密码保护的工作簿中成功执行了此脚本。
遵循以下步骤：
开发人员 – >loggingmacros（给一个名字，然后做点击）
macros – >将您创build的macros用于编辑。
用下面的整个函数replacemacros：
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
也许有一些帮助？
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