Excel spreadsheet password cracking using VBA

Question

I tried writing a vba password 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.

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

Answer 1

It looks like you're trying to unlock a workbook with a password to open it?

You absolutely should not be using Sendkeys for that. You should only ever use sendkeys as a last resort.

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.

If you are trying to unlock the vba code, follow the comment by JimmyPena

Here's a reference for someone using similar code to yours for unlocking the active sheet.

Answer 2

I successfully executed this script in Excel-2013 on a password protected workbook created in 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

Answer 3

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.

This SO article explains this as well, with greater detail: Excel VBA - Automatically Input Password

EDIT

For 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 Samples entry appears to have a working version for unprotecting a 2003 workbook.

Also, on a related note, if you are stepping back even further and trying to unlock a VBA project, this SO article appears to adequately address the issue.

For 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.

---

Answer 4

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