excel工作表密码忘记/破解

  1. Public Sub 工作表保护密码破解()  
  2. Const DBLSPACE As String = vbNewLine & vbNewLine  
  3. Const AUTHORS As String = DBLSPACE & vbNewLine & _  
  4. "作者:McCormick   JE McGimpsey "  
  5. Const HEADER As String = "工作表保护密码破解"  
  6. Const VERSION As String = DBLSPACE & "版本 Version 1.1.1"  
  7. Const REPBACK As String = DBLSPACE & ""  
  8. Const ALLCLEAR As String = DBLSPACE & "该工作簿中的工作表密码保护已全部解除!!" & DBLSPACE & "请记得另保存" _  
  9. & DBLSPACE & "注意:不要用在不当地方,要尊重他人的劳动成果!"  
  10. Const MSGNOPWORDS1 As String = "该文件工作表中没有加密"  
  11. Const MSGNOPWORDS2 As String = "该文件工作表中没有加密2"  
  12. Const MSGTAKETIME As String = "解密需花费一定时间,请耐心等候!" & DBLSPACE & "按确定开始破解!"  
  13. Const MSGPWORDFOUND1 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _  
  14. "如果该文件工作表有不同密码,将搜索下一组密码并修改清除"  
  15. Const MSGPWORDFOUND2 As String = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _  
  16. "如果该文件工作表有不同密码,将搜索下一组密码并解除"  
  17. Const MSGONLYONE As String = "确保为唯一的?"  
  18. Dim w1 As Worksheet, w2 As Worksheet  
  19. Dim i As Integer, j As Integer, k As Integer, l As Integer  
  20. Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer  
  21. Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer  
  22. Dim PWord1 As String  
  23. Dim ShTag As Boolean, WinTag As Boolean  
  24. Application.ScreenUpdating = False  
  25. With ActiveWorkbook  
  26. WinTag = .ProtectStructure Or .ProtectWindows  
  27. End With  
  28. ShTag = False  
  29. For Each w1 In Worksheets  
  30. ShTag = ShTag Or w1.ProtectContents  
  31. Next w1  
  32. If Not ShTag And Not WinTag Then  
  33. MsgBox MSGNOPWORDS1, vbInformation, HEADER  
  34. Exit Sub  
  35. End If  
  36. MsgBox MSGTAKETIME, vbInformation, HEADER  
  37. If Not WinTag Then  
  38. Else  
  39. On Error Resume Next  
  40. Do 'dummy do loop  
  41. For i = 65 To 66: For j = 65 To 66: For k = 65 To 66  
  42. For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66  
  43. For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66  
  44. For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126  
  45. With ActiveWorkbook  
  46. .Unprotect Chr(i) & Chr(j) & Chr(k) & _  
  47. Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _  
  48. Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)  
  49. If .ProtectStructure = False And _  
  50. .ProtectWindows = False Then  
  51. PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _  
  52. Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _  
  53. Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)  
  54. MsgBox Application.Substitute(MSGPWORDFOUND1, _  
  55. "$$", PWord1), vbInformation, HEADER  
  56. Exit Do 'Bypass all for…nexts  
  57. End If  
  58. End With  
  59. NextNextNextNextNextNext  
  60. NextNextNextNextNextNext  
  61. Loop Until True  
  62. On Error GoTo 0  
  63. End If  
  64.   
  65. If WinTag And Not ShTag Then  
  66. MsgBox MSGONLYONE, vbInformation, HEADER  
  67. Exit Sub  
  68. End If  
  69. On Error Resume Next  
  70.   
  71. For Each w1 In Worksheets  
  72. 'Attempt clearance with PWord1  
  73. w1.Unprotect PWord1  
  74. Next w1  
  75. On Error GoTo 0  
  76. ShTag = False  
  77. For Each w1 In Worksheets  
  78. 'Checks for all clear ShTag triggered to 1 if not.  
  79. ShTag = ShTag Or w1.ProtectContents  
  80. Next w1  
  81. If ShTag Then  
  82. For Each w1 In Worksheets  
  83. With w1  
  84. If .ProtectContents Then  
  85. On Error Resume Next  
  86. Do 'Dummy do loop  
  87. For i = 65 To 66: For j = 65 To 66: For k = 65 To 66  
  88. For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66  
  89. For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66  
  90. For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126  
  91. .Unprotect Chr(i) & Chr(j) & Chr(k) & _  
  92. Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _  
  93. Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)  
  94. If Not .ProtectContents Then  
  95. PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _  
  96. Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _  
  97. Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)  
  98. MsgBox Application.Substitute(MSGPWORDFOUND2, _  
  99. "$$", PWord1), vbInformation, HEADER  
  100. 'leverage finding Pword by trying on other sheets  
  101. For Each w2 In Worksheets  
  102. w2.Unprotect PWord1  
  103. Next w2  
  104. Exit Do 'Bypass all for…nexts  
  105. End If  
  106. NextNextNextNextNextNext  
  107. NextNextNextNextNextNext  
  108. Loop Until True  
  109. On Error GoTo 0  
  110. End If  
  111. End With  
  112. Next w1  
  113. End If  
  114. MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK , vbInformation, HEADER  
  115. End Sub  

 

点赞

发表评论

电子邮件地址不会被公开。 必填项已用*标注