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:

Download Add-In

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