Jump to content
Sign in to follow this  
shihori

Excel Password

Recommended Posts

Go to the developers tab in Excel (if you don’t have it: File, Options, Customize ribbon: Select Developer in Main tabs)
Open Visual Basic (Code group)
sect your workbook (VBA project)
Choose Insert Module
Paste the code in the module
 
----code below----
Public Sub Remove_Password()                '  Koden är hämtad från http://mcgimpsey.com/excel/removepwords.html        '  Distribuerad enligt GNU General Public License	' OBS! koden används på egen risk och med eget ansvar        ' Läs denna innan du distribuerar vidare: http://www.gnu.org/licenses/gpl.html        ' Breaks worksheet and workbook structure passwords. Bob McCormick         '  probably originator of base code algorithm modified for coverage         '  of workbook structure / windows passwords and for multiple passwords        '        ' Norman Harker and JE McGimpsey 27-Dec-2002 (Version 1.1)        ' Modified 2003-Apr-04 by JEM: All msgs to constants, and        '   eliminate one Exit Sub (Version 1.1.1)        ' Reveals hashed passwords NOT original passwords        Const DBLSPACE As String = vbNewLine & vbNewLine        Const AUTHORS As String = DBLSPACE & vbNewLine & _                "Adapted from Bob McCormick base code by" & _                "Norman Harker and JE McGimpsey"        Const HEADER As String = "AllInternalPasswords User Message"        Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04"        Const REPBACK As String = DBLSPACE & "Please report failure " & _                "to the microsoft.public.excel.programming newsgroup."        Const ALLCLEAR As String = DBLSPACE & "The workbook should " & _                "now be free of all password protection, so make sure you:" & _                DBLSPACE & "SAVE IT NOW!" & DBLSPACE & "and also" & _                DBLSPACE & "BACKUP!, BACKUP!!, BACKUP!!!" & _                DBLSPACE & "Also, remember that the password was " & _                "put there for a reason. Don't stuff up crucial formulas " & _                "or data." & DBLSPACE & "Access and use of some data " & _                "may be an offense. If in doubt, don't."        Const MSGNOPWORDS1 As String = "There were no passwords on " & _                "sheets, or workbook structure or windows." & AUTHORS & VERSION        Const MSGNOPWORDS2 As String = "There was no protection to " & _                "workbook structure or windows." & DBLSPACE & _                "Proceeding to unprotect sheets." & AUTHORS & VERSION        Const MSGTAKETIME As String = "After pressing OK button this " & _                "will take some time." & DBLSPACE & "Amount of time " & _                "depends on how many different passwords, the " & _                "passwords, and your computer's specification." & DBLSPACE & _                "Just be patient! Make me a coffee!" & AUTHORS & VERSION        Const MSGPWORDFOUND1 As String = "You had a Worksheet " & _                "Structure or Windows Password set." & DBLSPACE & _                "The password found was: " & DBLSPACE & "$$" & DBLSPACE & _                "Note it down for potential future use in other workbooks by " & _                "the same person who set this password." & DBLSPACE & _                "Now to check and clear other passwords." & AUTHORS & VERSION        Const MSGPWORDFOUND2 As String = "You had a Worksheet " & _                "password set." & DBLSPACE & "The password found was: " & _                DBLSPACE & "$$" & DBLSPACE & "Note it down for potential " & _                "future use in other workbooks by same person who " & _                "set this password." & DBLSPACE & "Now to check and clear " & _                "other passwords." & AUTHORS & VERSION        Const MSGONLYONE As String = "Only structure / windows " & _                 "protected with the password that was just found." & _                 ALLCLEAR & AUTHORS & VERSION & REPBACK        Dim w1 As Worksheet, w2 As Worksheet        Dim i As Integer, j As Integer, k As Integer, l As Integer        Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer        Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer        Dim PWord1 As String        Dim ShTag As Boolean, WinTag As Boolean                Application.ScreenUpdating = False        With ActiveWorkbook            WinTag = .ProtectStructure Or .ProtectWindows        End With        ShTag = False        For Each w1 In Worksheets                ShTag = ShTag Or w1.ProtectContents        Next w1        If Not ShTag And Not WinTag Then            MsgBox MSGNOPWORDS1, vbInformation, HEADER            Exit Sub        End If        MsgBox MSGTAKETIME, vbInformation, HEADER        If Not WinTag Then            MsgBox MSGNOPWORDS2, vbInformation, HEADER        Else          On Error Resume Next          Do      'dummy do loop            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            With ActiveWorkbook              .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 .ProtectStructure = False And _              .ProtectWindows = False Then                  PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _                    Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _                    Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)                  MsgBox Application.Substitute(MSGPWORDFOUND1, _                        "$$", PWord1), vbInformation, HEADER                  Exit Do  'Bypass all for...nexts              End If            End With            Next: Next: Next: Next: Next: Next            Next: Next: Next: Next: Next: Next          Loop Until True          On Error GoTo 0        End If        If WinTag And Not ShTag Then          MsgBox MSGONLYONE, vbInformation, HEADER          Exit Sub        End If        On Error Resume Next        For Each w1 In Worksheets          'Attempt clearance with PWord1          w1.Unprotect PWord1        Next w1        On Error GoTo 0        ShTag = False        For Each w1 In Worksheets          'Checks for all clear ShTag triggered to 1 if not.          ShTag = ShTag Or w1.ProtectContents        Next w1        If ShTag Then            For Each w1 In Worksheets              With w1                If .ProtectContents Then                  On Error Resume Next                  Do      'Dummy do loop                    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                    .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 Not .ProtectContents Then                      PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _                        Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _                        Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)                      MsgBox Application.Substitute(MSGPWORDFOUND2, _                            "$$", PWord1), vbInformation, HEADER                      'leverage finding Pword by trying on other sheets                      For Each w2 In Worksheets                        w2.Unprotect PWord1                      Next w2                      Exit Do  'Bypass all for...nexts                    End If                    Next: Next: Next: Next: Next: Next                    Next: Next: Next: Next: Next: Next                  Loop Until True                  On Error GoTo 0                End If              End With            Next w1        End If        MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER    End Sub
----code above----
 
Close the VBA-window
Go to Macros (in Code group) Run your macro “Remove_Password”

Passwords are gone!

Note 1: The password that is displayed is the hashed (mathematically transformed) password (12 characters) and not the actual password.

Share this post


Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now
Sign in to follow this  

×