Bakus Blog

Just another rzeczywistość…

Odblokowywanie zabezpieczonych arkuszy MsExcel

Kopiuj-wklej z sieci, ale może się przydać 🙂

  • Uruchom edytor makr
  • Wklej:
    Public Sub AllInternalPasswords()
    '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
    'Reveals passwords NOT "the" passwords
    Const DBLSPACE As String = vbNewLine & vbNewLine
    Dim Mess As String, Header As String
    Dim Authors As String, Version As String
    Dim RepBack As String, AllClear As String
    Dim PWord1 As String
    Dim ShTag As Boolean, WinTag As Boolean
    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
    Application.ScreenUpdating = False
    Header = "AllInternalPasswords User Message"
    Authors = DBLSPACE & vbNewLine & "Adapted from Bob " & _
    "McCormick base code by Norman Harker " & _
    "and JE McGimpsey"
    Version = DBLSPACE & "Version 1.1 27-Dec-2002"
    RepBack = DBLSPACE & "Please report success or " & _
    "failure back to newsgroup."
    AllClear = 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 offence. If in doubt, don't."
    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
    Mess = "There were no passwords on sheets, or workbook " & _
    "structure or windows." & Authors & Version
    MsgBox Mess, vbInformation, Header
    Exit Sub
    End If
    Mess = "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
    MsgBox Mess, vbInformation, Header
    If Not WinTag Then
    Mess = "There was no protection to workbook structure " & _
    "or windows." & DBLSPACE & _
    "Proceeding to unprotect sheets." & _
    Authors & Version
    MsgBox Mess, 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)
    Mess = "You had a Worksheet Structure or " & _
    "Windows Password set." & DBLSPACE & _
    "The password found was: " & DBLSPACE & _
    PWord1 & 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
    MsgBox Mess, 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
    Mess = "Only structure / windows protected with " & _
    "the password that was just found." & _
    AllClear & Authors & Version & RepBack
    MsgBox Mess, 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 Not ShTag Then
    Mess = AllClear & Authors & Version & RepBack
    MsgBox Mess, vbInformation, Header
    Exit Sub
    End If
    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)
    Mess = "You had a Worksheet password set." & _
    DBLSPACE & "The password found was: " & _
    DBLSPACE & PWord1 & 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
    MsgBox Mess, 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
    Mess = AllClear & Authors & Version & RepBack
    MsgBox Mess, vbInformation, Header
    End Sub
  • 3. Uruchom
  • 4. Hasła zapisywać nie trzeba – arkusz jest już odblokowany 🙂

Posted under: Szybkie publikacje

Tagged as: , ,

Comments are closed.