Desproteger Excel 2013 – Desproteger Excel VBA

8

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 - [email protected]                                '
' Desenvolvido em 09/05/2015 - 23:45                                        '
' Duvidas entrar em contato pelo email [email protected]        '
'----------------------------------------------------------------------------
 
    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 = "<sheetProtection selectLockedCells=" & """1""" & " selectUnlockedCells=" & """1""" & "/>"
 
        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, "<sheetProtection algorithmName")
                Texto_Final = strLine
                If Valor_Ini_xls > 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
Veja também  Somar horas em uma planilha Excel
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 = "<sheetProtection selectLockedCells=" & """1""" & " selectUnlockedCells=" & """1""" & "/>" 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, "<sheetProtection algorithmName") Texto_Final = strLine If Valor_Ini_xls > 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 [email protected]
[email protected]-----------
 
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
Veja também  Habilitar a guia desenvolvedor no Excel e copiar procedimentos VBA Excel
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
Veja também  Reexibir todas as planilhas e Ocultar as planilhas novamente - Excel VBA
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

8 COMENTÁRIOS

DEIXE UMA RESPOSTA

Please enter your comment!
Please enter your name here