|
|
因工作需要，需要批量解除指定文件夹下的数百个excel，因为是不同部门提交上来的，保护密码多种多样，在论坛找到了合适单个文件解除的代码，但看着太复杂不知道怎么改造成“可选择文件夹”批量解密的版本，还请各位大佬赐教~！- Public Sub 工作表解除保护()
- Const DBLSPACE As String = vbNewLine & vbNewLine
- Const AUTHORS As String = DBLSPACE & vbNewLine
- Const HEADER As String = "工作表保护密码"
- Const VERSION As String = DBLSPACE & ""
- Const REPBACK As String = DBLSPACE & ""
- Const ZHENGLI As String = DBLSPACE & " "
- 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, vbInformation, HEADER
- End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2022-11-28 16:37
楼主