解鎖---工作表保護密碼

•  1.打開要破解工作表文件
• 2.錄製宏，把他創建在“個人宏工作薄”
• 3. 創建後什麼都不用操作，直接停止錄製宏
• 4. 在VB中找到該宏函數
• 5.將下面代碼賦值到程序中

• Public Sub 工作表保護密碼破解()
  Const DBLSPACE As String = vbNewLine & vbNewLine
  Const AUTHORS As String = DBLSPACE & vbNewLine & _
  "作者:McCormick   JE McGimpsey "
  Const HEADER As String = "工作表保護密碼破解"
  Const VERSION As String = DBLSPACE & "版本 Version 1.1.1"
  Const REPBACK As String = DBLSPACE & ""
  Const ZHENGLI As String = DBLSPACE & "                        FGHRSH 整理"
  Const ALLCLEAR As String = DBLSPACE & "該工作簿中的工作表密碼保護已全部解除!!" & DBLSPACE & "請記得另保存" _
  & DBLSPACE & "注意：不要用在不當地方，要尊重他人的勞動成果！"
  Const MSGNOPWORDS1 As String = "該文件工作表中沒有加密"
  Const MSGNOPWORDS2 As String = "該文件工作表中沒有加密2"
  Const MSGTAKETIME As String = "解密需花費一定時間,請耐心等候!" & DBLSPACE & "按確定開始破解!"
  Const MSGPWORDFOUND1 As String = "密碼重新組合爲:" & DBLSPACE & "$$" & DBLSPACE & _
  "如果該文件工作表有不同密碼,將搜索下一組密碼並修改清除"
  Const MSGPWORDFOUND2 As String = "密碼重新組合爲:" & DBLSPACE & "$$" & DBLSPACE & _
  "如果該文件工作表有不同密碼,將搜索下一組密碼並解除"
  Const MSGONLYONE As String = "確保爲唯一的?"
  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
  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 & ZHENGLI, vbInformation, HEADER
  End Sub

   

• 6. 將剛錄製的宏，指向執行復制的代碼
• 7.點擊執行