Thursday, January 21, 2010

Excel password crack. Recover your forgotten password for free.

There is simple way to recover forgotten Excel password using Excel itself. I wrote a small VBA addin for this purpose. You can use it for free to recover your forgotten Excel password.
But if you like it, please consider making a donation.
Source code is open so you could see how it works. Here is link for addin download:


The idea is to iterate fake passwords (up to 8 characters) where first 1-8 characters are "A" or "B" and last one have code from 32 to 255. This utility works with Excel 97/2000/2003 only.  Excel 2007 have stronger protection and this method doesn't work there.


Here is source code with comments:
Const MENUNAME = "UNPROTECT"
Sub test()
On Error Resume Next
    Dim wb As Workbook
    Const LastCharStart = 32
    Const LastCharFinish = 255
    For i = 1 To 255
        fakepassword = FakePass(i)
        For LastCharIndex = LastCharStart To LastCharFinish
            Password = fakepassword & Chr(LastCharIndex)
            Set wb = Workbooks.Open("trypass.xls", , , , Password)
            Debug.Print Password
            If Not wb Is Nothing Then: Exit For
        Next
    Next
End Sub
'Install menu shortcut
Sub Auto_Open()
    Install
End Sub

'Crack Worksheets and Workbooks passwords at once
Sub BruteForceUnprotect()
    Dim ProtectedObjects As New Collection
    Const LastCharStart = 32
    Const LastCharFinish = 255
    
    Application.DisplayAlerts = False
    
    If Workbooks.Count <= 0 Then
        MsgBox "Open some workbook first!"
        Exit Sub
    End If
    
    
    'Add protected Workbooks to collection
    If (ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows) Then
        ProtectedObjects.Add ActiveWorkbook
    End If
    
    'Add protected Worksheets to collection
    On Error Resume Next
    'Dim WSheet As Worksheet
    For Each WSheet In ActiveWorkbook.Worksheets
        WSheet.Protect ("")
        If Not WSheet.Unprotect("") Then: ProtectedObjects.Add WSheet
    Next
    On Error GoTo 0
    
    If ProtectedObjects.Count <= 0 Then
        MsgBox "No protected objects or password is empty!"
        Exit Sub
    End If
    
    'Brute force with fake password. Original password could not be restored in this way.
    For i = 1 To 255
        fakepassword = FakePass(i)
        If ProtectedObjects.Count = 0 Then: Exit For
        For LastCharIndex = LastCharStart To LastCharFinish
            Password = fakepassword & Chr(LastCharIndex)
            If ProtectedObjects.Count > 0 Then
                For j = 1 To ProtectedObjects.Count
                    If UnprotectObject(ProtectedObjects(j), Password) = True Then
                        ProtectedObjects.Remove (j)
                        If ProtectedObjects.Count > 0 Then: j = j - 1
                    End If
                Next
            End If
        Next
    Next
    
    If ProtectedObjects.Count = 0 Then
        MsgBox "Workbook and Worksheets passwords was removed!"
    Else
        MsgBox "Non standard encryption detected :(. Some objects are still protected."
    End If
    Application.DisplayAlerts = True
End Sub
Function UnprotectObject(obj, pass)
  UnprotectObject = False
  On Error GoTo WrongPassword
  obj.Unprotect pass
  UnprotectObject = True
WrongPassword:
End Function
'Build password by given numeric value.
Function FakePass(Value)
    Mask = 1
    FakePass = ""
    While Mask <= Value
        If (Value And Mask) = 0 Then
            FakePass = "A" & FakePass
        Else
            FakePass = "B" & FakePass
        End If
        Mask = Mask * 2
    Wend
    If Len(FakePass) > 0 Then: FakePass = Right(FakePass, Len(FakePass) - 1)
End Function
'Install menu shortcut
Sub Install()
    Uninstall True
    AddButton MENUNAME, "Unprotect everything", "BruteForceUnprotect"
    AddButton MENUNAME, "Uninstall addon", "Uninstall"
End Sub
'Uninstall menu shortcut
Sub Uninstall(Optional silent = False)
    If Not silent Then
        If MsgBox("Do you really want to uninstall this addon ?", vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If
    On Error Resume Next
    Application.CommandBars("Worksheet Menu Bar").Controls(MENUNAME).Delete
    On Error GoTo 0
End Sub
'Add menu item
Sub AddButton(menu As String, submenu As String, macro As String, Optional descr As String = "")
    On Error GoTo createmenu
    If IsNull(Application.CommandBars("Worksheet Menu Bar").Controls(menu)) Then: GoTo createmenu
    On Error GoTo create
    If IsNull(Application.CommandBars("Worksheet Menu Bar").Controls(menu).Controls(submenu)) Then: GoTo create
    End
createmenu:
    Set mnu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=10)
    mnu.Caption = "&" & menu
    mnu.Visible = True
    
create:
    Set Button = Application.CommandBars("Worksheet Menu Bar").Controls(menu).Controls.Add(Type:=1, ID:=2950)
    With Button
        .DescriptionText = descr
        .TooltipText = descr
        .Caption = "&" & submenu
        .Style = 3
        .OnAction = macro
    End With
End Sub


5 comments:

  1. When i run it i get an error in this line.

    If UnprotectObject(ProtectedObjects(j), Password) = True Then

    ReplyDelete
  2. It may happen if ProtectedObjects collection is empty. Shouldn't happen though.
    I added few checks in the code. Please try it.
    What Office version do you use by the way ?

    ReplyDelete
  3. I also got a compile error: Expected Function or variable for this line: If Not WSheet.Unprotect(""). I am using Office 2007 to unprotect a .xls sheet with Excel 97-2003 format.

    ReplyDelete
  4. Please try to comment out that line(43):
    Dim WSheet As Worksheet
    By some reason Excel 2007 doesn't like it :/

    ReplyDelete
    Replies
    1. After commenting out that line, it works perfectly. If I'm using Office 2003, do I need to un-comment that line again? After searching on google, I got another VBA program that can remove password for Excel 2007/2010. Here is the link:
      http://www.top-password.com/blog/how-to-unprotect-a-password-protected-excel-2007-or-excel-2010-worksheet/

      Could you rewrite this VBA program or make your source code supports Excel 2007/2010? Thank you!

      Delete