关于excel密码 工作表密码 工作簿密码 工程密码

以下代码皆亲测可用

代码1：

可清除工作表、工作簿密码，并复制密码到剪切板

代码2：

绕过限制，把内容复制到新文件，相当于另存一份无工作簿保护

代码3：

可清除工作表密码，并复制密码到剪切板（不能清除工作簿保护及密码）

代码4：

清除工程密码

还有专用工具。

代码1：

可清除工作表、工作簿密码，并复制密码到剪切板

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)

With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
            .SetText Chr(i) & PWord1
            .PutInClipboard
        End With


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

代码2：

绕过限制，把内容复制到新文件，相当于另存一份无工作簿保护

Sub pojie()
    ActiveWorkbook.Sheets.Copy
    For Each sh In ActiveWorkbook.Sheets
        sh.Visible = True
    Next
End Sub

代码3：

可清除工作表密码，并复制密码到剪切板（不能清除工作簿保护及密码）

Sub PasswordBreaker()
　　Dim i As Integer, j As Integer, k As Integer
　　Dim l As Integer, m As Integer, n As Integer
　　Dim i1 As Integer, i2 As Integer, i3 As Integer
　　Dim i4 As Integer, i5 As Integer, i6 As Integer
　　On Error Resume Next
　　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
　　ActiveSheet.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 ActiveSheet.ProtectContents = False Then
　　MsgBox "One usable password is " & Chr(i) & Chr(j) & _
　　Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
　　Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
            .SetText Chr(i) & Chr(j) & _
　　Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
　　Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
            .PutInClipboard
        End With


　　ActiveWorkbook.Sheets(1).Select
　　Range("a1").FormulaR1C1 = Chr(i) & Chr(j) & _
　　Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
　　Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
　　Exit Sub
　　End If
　　Next: Next: Next: Next: Next: Next
　　Next: Next: Next: Next: Next: Next
　　End Sub

代码4：

清除工程密码

清除VBA工程密码：
Sub MoveProtect()
  Dim FileName As String
   FileName = Application.GetOpenFilename("Excel文件（*.xls & *.xlsx）,*.xls;*.xlsx", , "VBA破解")
   If FileName = CStr(False) Then
      Exit Sub
   Else
      VBAPassword FileName, False   '  引用下面的自定义函数
   End If
End Sub
Private Function VBAPassword(FileName As String, Optional Protect As Boolean = False)
     If Dir(FileName) = "" Then
        Exit Function
     Else
        FileCopy FileName, FileName & ".abc"
     End If
     Dim GetData As String * 5
     Open FileName For Binary As #1
     Dim CMGs As Long
     Dim DPBo As Long
     For i = 1 To LOF(1)
         Get #1, i, GetData
         If GetData = "CMG=""" Then CMGs = i
         If GetData = "[Host" Then DPBo = i - 2: Exit For
     Next i
     If CMGs = 0 Then
        MsgBox "请先对VBA编码设置一个保护密码...", 32, "提示"
        Exit Function
     End If

     If Protect = False Then
        Dim St As String * 2
        Dim s20 As String * 1                                         '取得一个0D0A十六进制字串
        Get #1, CMGs - 2, St                                          '取得一个20十六制字串
        Get #1, DPBo + 16, s20                                     '替换加密部份机码
        For i = CMGs To DPBo Step 2
            Put #1, i, St
        Next                                                                   '加入不配对符号
        If (DPBo - CMGs) Mod 2 <> 0 Then
           Put #1, DPBo + 1, s20
        End If
        MsgBox "文件解密成功......", 32, "提示"
     Else
        Dim MMs As String * 5
        MMs = "DPB="""
        Put #1, CMGs, MMs
        MsgBox "对文件特殊加密成功......", 32, "提示"
     End If
     Close #1
End Function

当然，还有强大的passware kit直接搞定一切，但是vba也有它的适用场景。