Por estarmos envolvidos em tantos projetos simultaneamente, não raro acontece de esquecermos as senhas de proteção das worksheets. Neste momento saimos correndo atrás de programas que possam desbloquear nossas planilhas. Abaixo está um bem estruturado código capaz de retirar a proteção das nossas woksheets. É uma implementação válida e digna de ficar sempre à mão. Agora poderá a qualquer momento copiá-la daqui e implementá-la em sua planilha para o pronto desbloqueio. Use a chamada para evocar a solução:
Call AllPasswordsRemover(ActiveWorkbook)
Public Sub AllPasswordsRemover(wb As Workbook)Dim w1 As Worksheet Dim w2 As Worksheet
Dim i As Integer Dim j As Integer Dim k As Integer
Dim l As Integer Dim m As Integer Dim n As Integer
Dim i1 As Integer Dim i2 As Integer Dim i3 As Integer
Dim i4 As Integer Dim i5 As Integer Dim i6 As Integer
Dim PWord1 As String Dim ShTag As Boolean
Dim WinTag As Boolean ' Início da tentativa de desproteger o wb (workBook), Application.ScreenUpdating = False ' Verifica se está protegido With wb Let WinTag = .ProtectStructure Or .ProtectWindows End With Let ShTag = False ' Estão realmente protegidos? For Each w1 In Worksheets Let ShTag = ShTag Or w1.ProtectContents Next w1 ' Caso não haja proteção, o processo é encerrado! If Not ShTag And Not WinTag Then GoTo exx End If ' Dependendo da senha e de quantas planilhas estiverem protegidas com diferentes senhas, ' o processo talvez leve um tempo considerável. Estimo entre 3-6 minutos por senha. If Not WinTag Then ' Workbook não está protegido... vai checar as planilhas... Else ' Workbook está protegido, desprontegendo-o On Error Resume Next Do 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 wb .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 Let 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) ' Achamos o password para este workbook. MsgBox "A Worksheet '" & w1.Name & "' foi desprotegida usando o seguinte hash " & _ "Hashed Password:" & Chr(13) & PWord1 & Chr(13) & "Tente desproteger outras " & _ "planilhas com este mesmo password..." Exit Do 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 ' Worksheets Não estão protegidas. GoTo exx End If ' Caso as worksheets estiverem protegidas... On Error Resume Next For Each w1 In Worksheets w1.Unprotect PWord1 Next w1 On Error GoTo 0 ShTag = False ' Checa se a tentativa foi bem sucedida. For Each w1 In Worksheets ' Checa para todas as ShTag engatilhadas para 1, se não. Let ShTag = ShTag Or w1.ProtectContents Next w1 ' Caso haja worksheet protegida, desprotege-a. If ShTag Then For Each w1 In Worksheets With w1 If .ProtectContents Then On Error Resume Next Do 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) ' Achamos 1! MsgBox "A Worksheet '" & w1.Name & "' foi desprotegida usando o seguinte hash " & _ "Hashed Password:" & Chr(13) & PWord1 & Chr(13) & "Tente desproteger outras " & _ "planilhas com este mesmo password..." For Each w2 In Worksheets w2.Unprotect PWord1 Next w2 Exit Do End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next Loop Until True On Error GoTo 0 Else Debug.Print ("Estas worksheets '" & w1.Name & "' não estavam protegidas.") End If End With Next w1 End If GoTo exx exx: Application.ScreenUpdating = True
End Sub
Para os que desejarem aprofundar-se na lógica do como foi possível chegar a este resultado poderão fazê-lo Aqui.
Nenhum comentário:
Postar um comentário