Desproteger Excel 2013 – Desproteger VBA
Neste artigo você tem um código para desproteger arquivos Excel de tipos XLSX e XLSM de uma forma simples utilizando VBA.
Esta planilha foi cedida pelo mestre Fábio Baldini e está disponível para download no final deste artigo.
O método de quebra de senha utilizado nesta programação, permite a quebra das senhas das planilhas do Excel 2013.
Este código permite desproteger as planilhas no Excel 2013 em diante, o método é diferente do amplamente difundido na internet como 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.
Como utilizar a planilha para Desproteger Planilha e Remover senha do VBA Excel
Para que a planilha funcione o arquivo Excel tem que estar sem acentuações e salvo na área de trabalho.
Faça o backup da planilha antes de realizar o processo:
“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.”
Código fonte para desproteger planilhas Excel e desbloquear VBA Excel xlsx e xlsm
Para desproteger o arquivo basta clicar na guia Desenvolvedor e selecionar a macro Desproteger.
Então selecione o arquivo que deseja desproteger e o mesmo tem então todas as senhas removidas automaticamente do Excel.
Abaixo o código fonte que realiza a remoção da senha da planilha.
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
Como desproteger VBA Excel
Para desproteger o código VBA é utilizado o código abaixo, chame então no VBA o GeneralSUB e selecione o arquivo.
Ao processar o arquivo é alterada a senha do VBA e exibida a nova senha.
'---------------------------------------------------------------------------
' 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
Download da planilha de Desproteger Planilha e VBA
Clique no botão abaixo para baixar a planilha de desproteger planilhas e VBA.
Baixe a planilhaAbraço
Marcos Rieper
Curso Excel Completo – Do Básico ao VBA
Quer aprender Excel do Básico, passando pela Avançado e chegando no VBA? Clique na imagem abaixo:
