Desproteger Excel 2013 – Desproteger Excel VBA

Novo layout Guia do Excel
Novo site Guia do Excel
4 de outubro de 2015
Mapa de férias Excel
Mapa de férias Excel
10 de outubro de 2015

Desproteger Excel 2013 – Desproteger Excel VBA

Este é um artigo publicado no link http://www.excelsolutions.com.br/desproteger-planilha-do-excel-2013-sem-utilizar-programacao-vba/ no site Excel Solutions pelo meu engenheiro e professor Fábio Baldini, que liberou para que fosse publicada também no Guia do Excel.

Neste vídeo, temos uma planilha com macros que desprotegem as guias de arquivos Excel de extensões XLSX ou XLSM, ou seja, de Excel 2007 em diante.

O método de quebra de senha utilizado nesta programação, permite a quebra das senhas das planilhas do Excel 2013, o que não acontecia com o código já muito difundido na internet para quebrar senhas, veja no artigo Desbloquear planilha com Excel VBA.

Neste artigo o Fábio fez dois códigos, um para desproteger as planilhas e outro para retirar senha do código VBA de uma planilha. Ambos são muito úteis e eu sugiro que guarde a planilha e o código divulgado.

“Para funcionar é necessário que sejam removidos todos os caracteres com acento do nome do arquivo e que este seja salvo na área de trabalho. Faça um backup do arquivo antes de aplicar o desbloqueio.”

Abaixo o vídeo do Excel Solutions:

Baixe o arquivo neste link:

Abaixo o código VBA para desbloqueio das planilhas Excel 2013. Veja neste link como utilizá-los: Habilitando a Guia Desenvolvedor e copiando procedimentos VBA da Internet.

Public Pasta_Arquivo As String
Sub Desprotegendo()
'----------------------------------------------------------------------------
' Algoritmo Desenvolvido por Prof. Eng. Fabio Baldini                       '
' Se Inscreva em nosso Canal - https://www.YouTube.com/ExcelSolutionsBr     '
' Contatos - Comercial@excelsolutions.com.br                                '
' Desenvolvido em 09/05/2015 - 23:45                                        '
' Duvidas entrar em contato pelo email contato@excelsolutions.com.br        '
'----------------------------------------------------------------------------

    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String
    Dim strDate As String
    Dim FileNameZip, FolderName, oFolder
    Dim oApp1 As Object
    Dim MyPath As String
    Dim str As String
    
    str = Application.GetOpenFilename("Excel Files (*.xls;*.xlsb;*.xlsx;*.xlsm),*.xls;*.xlsb;*.xlsx;*.xlsm")
    If Not str = "Falso" And Not str = "False" Then
        
        lastSlash = InStrRev(str, "\")
        'str1 = Mid(str, lastSlash + 1)
        
        Caminho = str
        Ponto = InStrRev(Caminho, ".")
        Extensao = Mid(Caminho, Ponto + 1, Len(Caminho) - Ponto)
        Caminho_Zip = Left(Caminho, Ponto - 1) & ".zip"
        Nome_Arquivo = Mid(Caminho, InStrRev(Caminho, "\") + 1, Len(Caminho))
        Pasta_Arquivo = Replace(Caminho, "\" & Nome_Arquivo, "")
        Nome_Arquivo_1 = Mid(Caminho, InStrRev(Caminho, "\") + 1, Ponto - InStrRev(Caminho, "\") - 1)
        
        Call Limpa_Pasta
        
        Name Caminho As Caminho_Zip
    
        Fname = Caminho_Zip
        DefPath = Pasta_Arquivo
        If Right(DefPath, 1)  "\" Then
            DefPath = DefPath & "\"
        End If
    
        FileNameFolder = DefPath & "Arquivo1\"
    
        MkDir FileNameFolder
    
        Set oApp = CreateObject("Shell.Application")
    
        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
    
        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    
        Arquivos = Dir(FileNameFolder & "xl\worksheets\*.xml")
        Valor_Substituido = ""
        
        While Arquivos  Empty
            
            Close #1
            Open FileNameFolder & "xl\worksheets\" & Arquivos For Input As #1
            strFinal = Empty
            Texto_Final = Empty
            While EOF(1) = False
    
                Line Input #1, strLine
                Valor_Ini_xls = InStr(strLine, "<sheetProtection password")
                Valor_Ini_xlsx = InStr(strLine, " 0 Then
                    Valor_Fim = InStr(Valor_Ini_xls, strLine, ">")
                    Texto_Final = Left(strLine, Valor_Ini_xls - 1) & Valor_Substituido & Mid(strLine, Valor_Fim + 1, Len(strLine))
                End If
                If Valor_Ini_xlsx > 0 Then
                     Valor_Fim = InStr(Valor_Ini_xlsx, strLine, ">")
                     Texto_Final = Left(strLine, Valor_Ini_xlsx - 1) & Valor_Substituido & Mid(strLine, Valor_Fim + 1, Len(strLine))
                End If
                strFinal = strFinal + Texto_Final
            Wend
            Texto_Final = Empty
            Close #1
            
            Open FileNameFolder & "xl\worksheets\" & Arquivos For Output As #1
            Print #1, strFinal
            Close #1
            
            Arquivos = Dir()
        Wend
        
        DefPath = Pasta_Arquivo
        If Right(DefPath, 1)  "\" Then
            DefPath = DefPath & "\"
        End If
    
        FileNameZip = DefPath & Nome_Arquivo_1 & ".zip"
    
        Set oApp1 = CreateObject("Shell.Application")
    
        NewZip (FileNameZip)
    
        FolderName = DefPath & "Arquivo1"
        If Right(FolderName, 1)  "\" Then
            FolderName = FolderName & "\"
        End If
    
        oApp1.Namespace(FileNameZip).CopyHere oApp1.Namespace(FolderName).items
    
        On Error Resume Next
        Do Until oApp1.Namespace(FileNameZip).items.Count = oApp1.Namespace(FolderName).items.Count
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0
    
        Name Caminho_Zip As Caminho
        Call Limpa_Pasta
        Call Limpa_Pasta
        MsgBox "Arquivo Desprotegido com Sucesso!", vbInformation, "Atenção!"
    End If
End Sub

Sub NewZip(sPath)
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub
Sub Limpa_Pasta()
    On Error Resume Next
    Set FSO = CreateObject("scripting.filesystemobject")

    MyPath = Pasta_Arquivo & "\Arquivo1"

    If Right(MyPath, 1) = "\" Then
        MyPath = Left(MyPath, Len(MyPath) - 1)
    End If

    If FSO.FolderExists(MyPath) = True Then
        Application.Wait (Now + TimeValue("0:00:02"))
        FSO.deletefolder MyPath & "\*.*", True
        FSO.deletefolder MyPath
    End If
    On Error GoTo -1
End Sub

Abaixo o código para desproteger o VBA:

'---------------------------------------------------------------------------
' Créditos a remoção do VBA para o site - http://lbeliarl.blogspot.com.br/
' Anton 23-03-2014
' Alteração para a senha 'excelsolutions'
' Duvidas entrar em contato pelo email contato@excelsolutions.com.br
'---------------------------------------------------------------------------

Option Base 1

Function ProtectedVBProject(ByRef wb As Workbook) As Boolean

Dim VBC As Integer

VBC = -1
On Error Resume Next
  VBC = wb.VBProject.VBComponents.Count
On Error GoTo 0

If VBC = -1 Then
  ProtectedVBProject = True
Else
  ProtectedVBProject = False
End If

End Function


Sub GeneralSub()

Dim CopyFname As Variant
Dim FileNameFolder As Variant

ChDir (Environ("USERPROFILE") & "\Desktop")

Fname = Application.GetOpenFilename(filefilter:="Excel files (*.xlsm), *.xlsm", MultiSelect:=False)

If Fname = False Then
    Exit Sub
End If

On Error Resume Next
Dim tmpWB As Workbook

Set tmpWB = Workbooks.Open(Fname, ReadOnly:=True, Password:="")
If Err.Number > 0 Then
  MsgBox "O arquivo selecionado está encriptado (Senha de abertura)!" & vbCrLf & "Este prgrama não funciona com a senha de abertura.", vbCritical, "Desproteção VBA"
  Exit Sub
End If
On Error GoTo 0

If tmpWB.MultiUserEditing = True Then

  tmpWB.Close saveChanges:=False
  MsgBox "O arquivo selecionado está em modo de compartilhamento!" & vbCrLf & "Por gentileza altere esse modo para exclusivo (Não Compartilhado) e tente novamente!", vbExclamation, "Desproteção VBA"
  Exit Sub
End If

ProjectProtected = ProtectedVBProject(tmpWB)

tmpWB.Close saveChanges:=False
Set tmpWB = Nothing

If ProjectProtected Then

        Dim FSO As Object
        Set FSO = CreateObject("scripting.filesystemobject")

        CopyFname = Left(Fname, Len(Fname) - 4) & "zip"
        LastSeparatorPos = Len(CopyFname) - InStr(1, StrReverse(CopyFname), CStr(Application.PathSeparator), vbTextCompare) + 1
        CopyFname = Left(CopyFname, LastSeparatorPos) & "Desprotegido_" & Right(CopyFname, Len(CopyFname) - LastSeparatorPos)
        
        FSO.CopyFile Fname, CopyFname, True

        FileNameFolder = Environ("tmp") & "\UnlockFolderTMP"

        If FSO.FolderExists(FileNameFolder & "\") Then
           FSO.deletefolder FileNameFolder
        End If

        FSO.CreateFolder FileNameFolder
End If

Dim OutMSG As String
OutMSG = ""

If ProjectProtected = True Then
   OutMSG = ChangePasswordForVBA(CopyFname, FileNameFolder)
Else
   OutMSG = "O Arquivo selecionado não tem senha de Proteção no VBA!"
End If

If ProjectProtected Then
        If FSO.FolderExists(FileNameFolder & "\") Then
           FSO.deletefolder FileNameFolder
        End If

        CopyFname_unlocked = Left(CopyFname, Len(CopyFname) - 3) & "xlsm"

        If FSO.FileExists(CopyFname_unlocked) Then
          FSO.DeleteFile CopyFname_unlocked, True
        End If

        FSO.MoveFile CopyFname, CopyFname_unlocked
        Set FSO = Nothing
End If

MsgBox OutMSG, vbInformation, "Desproteção VBA"

End Sub


Function ChangePasswordForVBA(CopyFname As Variant, FileNameFolder As Variant) As String

Set oApp = CreateObject("Shell.Application")

ProjectFileFound = False

For Each fileNameInZip In oApp.Namespace(CopyFname).items
    If fileNameInZip = "xl" Then
       For Each subFile In fileNameInZip.Getfolder.items
            If subFile = "vbaProject.bin" Then
                  oApp.Namespace(FileNameFolder).movehere subFile
                  ProjectFileFound = True
                  Exit For
            End If
       Next
    End If
Next

''HASH for Password = 'excelsolutions'
Dim PasswordString As String
PasswordString = "858729CFD9D6F6D6F6290AD7F606B271AF8AB70384F2FC4A134364C356CE3EB34B4F62B5B6A2"

If ProjectFileFound = True Then
    tmpMSG = ""
    tmpMSG = ChangeDPBValue(FileNameFolder & "\vbaProject.bin", PasswordString)
    oApp.Namespace(CopyFname).items.Item("xl").Getfolder.CopyHere FileNameFolder & "\vbaProject.bin"

    On Error Resume Next
    Do Until oApp.Namespace(CopyFname).items.Item("xl").Getfolder.items.Item("vbaProject.bin").Name = "vbaProject.bin"
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
    On Error GoTo 0
    
    If tmpMSG = "" Then
        ChangePasswordForVBA = "A Senha do VbaProject foi alterado para: 'excelsolutions'"
    Else
        ChangePasswordForVBA = tmpMSG
    End If
    
Else
    ChangePasswordForVBA = "O Arquivo não tem VBA!"
End If

Set oApp = Nothing

End Function

Function ChangeDPBValue(PathToBinFile As String, HASHPassword As String) As String

Dim PasswordArrayByte() As Byte

Set adoStream = CreateObject("ADODB.Stream")
Set adoBin = CreateObject("ADODB.Stream")

ReDim PasswordArrayByte(Len(HASHPassword))

For i = 1 To Len(HASHPassword)
  PasswordArrayByte(i) = Asc(Mid(HASHPassword, i, 1))
Next i

With adoStream
    .Mode = 3
    .Type = 2
    .Charset = "us-ascii"
    .Open
    .LoadFromFile (PathToBinFile)
    bytes = .ReadText

    StartPosVal = InStr(1, bytes, "DPB=", vbTextCompare) + 5

    If StartPosVal = 5 Then
        .Close
        Set adoStream = Nothing
        Set adoBin = Nothing
        ChangeDPBValue = "Não encontrato a Proteção VBA!"
        Exit Function
    End If
    
    EndPosVal = InStr(StartPosVal, bytes, """", vbTextCompare) - 1
    ValLength = EndPosVal - StartPosVal + 1

    If Len(HASHPassword) < ValLength Then
       ReDim Preserve PasswordArrayByte(Len(HASHPassword) + ValLength - Len(HASHPassword))
       
       For i = Len(HASHPassword) + 1 To UBound(PasswordArrayByte)
          PasswordArrayByte(i) = Asc(0)
       Next i
    End If
        
    .Close
End With

With adoStream
    .Mode = 3
    .Type = 1
    .Open
    .LoadFromFile (PathToBinFile)
    
    With adoBin
        .Mode = 3
        .Type = 1
        .Open
    End With
     
    .Position = 0
    .CopyTo adoBin, StartPosVal - 1
    
     adoBin.Write (PasswordArrayByte)

    .Position = EndPosVal
    .CopyTo adoBin

    adoBin.SaveToFile PathToBinFile, 2
    adoBin.Close
    
    .Close
End With

Set adoStream = Nothing
Set adoBin = Nothing
ChangeDPBValue = ""

End Function

Artigo publicado no site Excel Solutions por Fábio Baldini.

Aproveito para conhecerem a empresa Excel Solutions e curtir a sua página do Facebook e do Youtube http://www.YouTube.com/ExcelSolutionsBr.

Abraço

Marcos Rieper

16 Comentários

  1. Olá Marcos obrigado pelo seu comentário e obrigado pelo post! E gostaria de divulgar o nosso canal no youtube – http://www.YouTube.com/ExcelSolutionsBr , Qualquer duvida estaremos a disposição, Abração!

  2. Adriana Cavalcanti disse:

    Sensacional!

  3. Rodrigo disse:

    Está dando erro: ChDir (Environ(“USERPROFILE”) & “\Desktop”)

  4. Sergio Alves da Silva disse:

    Muito bom!! Funcionou perfeitamente. E meu office é 2010.

  5. Gelson disse:

    Olá Marcos,

    Tentei usar no Ofice Mac 2011, e está dando erro – Run time error 1004 Method GetOpenfilename of object_ application failed

  6. Marcos Aurélio disse:

    Boa Noite!

    Marcos Rieper

    Infelizmente o código VBA não esta desbloqueado a planilha, poderia encaminhar para sua analise.

  7. Dalton disse:

    Prezado Marcos, estou rodando a macro mas só desbloqueia a planilha, a pasta de trabalho continua bloqueada, tem alguma dica?

  8. Dalton disse:

    Opa, já descobri uma maneira, roda a macro desbloqueando no arquivo excel 2013, salva como excel 97-2003, fecha o arquivo, abre de novo, clica em desbloquear pasta de trabalho, ele desbloqueia sem senha, aí vc pode salvar de novo com excel 2013. Obrigado!

  9. Douglas disse:

    Olá, como faço para mudar a senha que será colocada ao desbloquear? Ao invés de ‘excelsolutions’ se eu quiser colocar outra?

  10. Milan disse:

    Eita, 1 hora pra achar esse site, e resolveu! Parabéns!

  11. Reginaldo disse:

    PARABÉNS FORMIDÁVEL

Deixe uma resposta

O seu endereço de e-mail não será publicado. Campos obrigatórios são marcados com *

Inscreva-se no nosso canal do Youtube!


Junte-se ao nosso canal do Youtube. Começamos em abril de 2016, mas já temos mais de 06:00 h de treinamentos gratuitos e este número irá aumentar. Vídeos novos todos os sábados.