侧边栏壁纸
  • 累计撰写 12 篇文章
  • 累计创建 19 个标签
  • 累计收到 1 条评论
隐藏侧边栏

Excel破解密码.md

zjan
2021-09-22 / 0 评论 / 0 点赞 / 61 阅读 / 5,585 字
温馨提示:
本文最后更新于 2021-09-22,若内容或图片失效,请留言反馈。部分素材来自网络,若不小心影响到您的利益,请联系我们删除。

Excel破解密码

  1. 将Excel文件另存为带宏的工作簿
  2. 创建一个宏
    1. 开发工具->录制新宏->停止录制。这样就获得一个新的宏
  3. 宏中写如以下代码
Option Explicit
	
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 (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
  1. 执行宏稍等即可
0

评论区