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

Hi Jimmy thanks for the updates but the question is not using vbscript, it is doing via some hashcodes. — codeomnitrix, Jul 30 '12 at 08:17
Hi @codeomnitrix, can you please share your thoughts about why you only try A to B for the first 8 layers? Don't you want to try all possible characters on all layers? — lovechillcool, May 20 '16 at 16:38
Its because the password is converted to a series of A's and B's internally. no need to loop through all characters — codeomnitrix, May 21 '16 at 05:47

score 6 · Accepted Answer · edited May 23 '17 at 12:26

6

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.

edited May 23 '17 at 12:26

Community

1
1

answered Jul 25 '12 at 19:45

Scott Conover

1,421
1
14
27

1

Hi Jack, thanks for response, the excel file is not protected rather the vba project residing in it is protected. I need to unprotect this vba project using this script. – codeomnitrix Aug 03 '12 at 06:08
Codeomnitrix, thanks for the clarification. What version of excel are you looking to open? There are many ways to do it in 2003; I linked a tutorial for unprotecting a sheet in 2003 and earlier in my edited answer. – Scott Conover Aug 03 '12 at 14:47
This answer should be edited as only this portion is relevant *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.* – brettdj Sep 20 '12 at 04:57
@brettdj, are you requesting that all of the post be removed except for that italicized section, or all of the material appearing after that point in italics? – Scott Conover Sep 20 '12 at 14:13

rchacko · Answer 2 · 2014-07-25T03:52:48.510

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

It works for a password protected worksheet, not if the workbook has a password to open it, since you can't even add VBA code in such a case. — dan, Mar 04 '15 at 15:21

score 1 · Answer 3 · answered Jul 26 '12 at 03:06

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.

Hi Daniel, Many Thanks for help, but I think you misunderstood my question I need to crack password of vba project file, not of the sheet. And I don't know which object should i refer to unprotect its password. — codeomnitrix, Aug 03 '12 at 05:51

score 1 · Answer 4 · answered Jul 18 '13 at 03:40

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

Excel spreadsheet password cracking using VBA

4 Answers4

Linked