Macro para remover senhas de proteção

Ir em baixo

Macro para remover senhas de proteção

Mensagem por Ricardofs2 em Sab 2 Jun 2018 - 9:43

Primeiro habilite as macro e abra o console de macros com a sequencia alt+f11

Entao crie um novo módulo e

Cole esse código:


Código:


'Desproteger pasta de trabalho e planilha
Public Sub RetirarTodasSenhasInternasExcel()
    ' 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 & _
            "Adaptado do código base de Bob McCormick por " & _
            "Guia do Excel - www.guiadoexcel.com.br"
    Const HEADER As String = "AllInternalPasswords User Message"
    Const VERSION As String = DBLSPACE & "Versão 1.1.1 04/Abril/2003"
    Const REPBACK As String = DBLSPACE & ""
    Const ALLCLEAR As String = DBLSPACE & "A planilha deve estar agora " & _
            "livre de senhas de proteção, então:" & _
            DBLSPACE & "SALVE AGORA!" & DBLSPACE & "e também" & _
            DBLSPACE & "FAÇA UM BACKUP DA ANTIGA!!!" & _
            DBLSPACE & "Lembre-se que a senha foi " & _
            "colocada com algum propósito, Não estrague as fórmulas " & _
            "ou banco de dados." & DBLSPACE & "Acesso e uso de algumas informações " & _
            "pode ser contra a lei. Se tiver dúvida, não o faça."
    Const MSGNOPWORDS1 As String = "Não foram encontradas senhas no " & _
            "arquivo ou pasta de trabalho." & AUTHORS & VERSION
    Const MSGNOPWORDS2 As String = "Não existe proteção na  " & _
            "pasta de trabalho." & DBLSPACE & _
            "Preparando para desbloquear planilhas (Pressione OK se for preciso)." & AUTHORS & VERSION
    Const MSGTAKETIME As String = "Depois de dar OK " & _
            "isso vai demorar um pouco." & DBLSPACE & "A duração de tempo " & _
            "depende de quantas senhas diferentes, das " & _
            "próprias senhas e das especificações de seu computador." & DBLSPACE & _
            "Seja paciente e tome um café!" & AUTHORS & VERSION
    Const MSGPWORDFOUND1 As String = "Você tem agora a planilha ou " & _
            "pasta de trabalho desbloqueada." & DBLSPACE & _
            "Verificando e limpando outras senhas." & AUTHORS & VERSION
    Const MSGPWORDFOUND2 As String = "Você tem agora a planilha ou " & _
            "pasta de trabalho desbloqueada." & DBLSPACE & 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



Acesse a guia Desenvolvedor, pegue um botão e atribua a ele a sua nova macro que irá remover as proteções da planilha.

_________________
Técnico em Informática

avatar
Ricardofs2

Mensagens : 22
Data de inscrição : 21/03/2015
Idade : 38
Localização : Manaus

Ver perfil do usuário

Voltar ao Topo Ir em baixo

Voltar ao Topo

- Tópicos similares

 
Permissão deste fórum:
Você não pode responder aos tópicos neste fórum