Bem se for para desbloquear a senha de protecao do projeto vba do excel tente este codigo
Crie uma nova planilha entre em vba coloque um useform e um botao com o seguinte codigo
Private Sub DesprotegeVBA()
'-------------------------------------------------------------------
' Função para desproteger a senha do VBA
' Tradução by VenonStorm
'-------------------------------------------------------------------
Dim F As String ' conterá nome do arquivo a ser craqueado
Dim B As String
Dim NewF As String 'Nom de copie de secours
Dim NbTour As Long
Dim Ok As Boolean 'marcador
Dim Pointeur As Long 'Posição do ponteiro
Dim Nb As Long
Dim LgFile As Long
Dim Cle As Integer 'Chave
Dim p1 As Long, p2 As Long, p3 As Long 'posicionar no começo chave
Dim p11 As Long, p22 As Long, p33 As Long 'posicionar no final da chave
'Abrir arquivo
F = "F:meus documentosExcelExcelTrek.xls" '==> ATENÇÃO: colocar aqui o NOME E CAMINHO do arquivo que contém a senha
If F = "" Then Exit Sub 'verifica se o arquivo foi especificado
NewF = F & ".tmp"
If Dir(NewF) <> "" Then ' verifica se o arquivo já existe
Kill NewF
End If
Call CopyFile(F, NewF) 'Cria um arquivo de backup
'Desprotege a senha do VBA
B = String$(512, " ")
Open F For Binary As #1
LgFile = LOF(1)
Cle = 0
Do
Pointeur = Loc(1) 'posiciona o ponteiro
Get #1, , B
'Chave da busca CMG="
p1 = InStr(1, B, "CMG=" & Chr$(34), vbBinaryCompare)
If p1 <> 0 Then
'citação da busca - marcas do fechamento
p11 = InStr(p1 + 5, B, Chr$(34), vbBinaryCompare)
If p11 <> 0 Then 'apaga a chave
Mid(B, p1, p11 - p1 + 1) = Space$(p11 - p1 + 1)
Ok = True
Cle = Cle + 1
End If
End If
'Chave da busca DPB="
p2 = InStr(1, B, "DPB=" & Chr$(34), vbBinaryCompare)
If p2 <> 0 Then
'citação da busca - marcas do fechamento
p22 = InStr(p2 + 5, B, Chr$(34), vbBinaryCompare)
If p22 <> 0 Then 'apaga a chave
Mid(B, p2, p22 - p2 + 1) = Space$(p22 - p2 + 1)
Ok = True
Cle = Cle + 1
End If
End If
'Chave da busca GC="
p3 = InStr(1, B, "GC=" & Chr$(34), vbBinaryCompare)
If p3 <> 0 Then
'citação da busca - marcas do fechamento
p33 = InStr(p3 + 5, B, Chr$(34), vbBinaryCompare)
If p33 <> 0 Then 'apaga a chave
Mid(B, p3, p33 - p3 + 1) = Space$(p33 - p3 + 1)
Ok = True
Cle = Cle + 1
End If
End If
If Ok Then 'gravar o bloco
Put #1, Pointeur + 1, B
Ok = False
End If
'se as 3 chaves foram apagadas => para a busca
If Cle = 3 Then Exit Do
'mover para trás de 100 bytes para evitar um corte
Seek #1, Loc(1) - 99
Loop Until Pointeur > LgFile
Close #1
'Mensagem
Select Case Cle
Case 0
Kill NewF
MsgBox "Não foi detectada proteção"
Case 1, 2
MsgBox "Operação incompleta, arquivo incompatível " & _
vbCrLf & vbCrLf & "Arquivo de backup: " & vbCrLf & vbCrLf & NewF
Case 3
MsgBox "Operação concluída com sucesso!!!"
End Select
End Sub
Private Sub CopyFile(Ancien As String, Nouveau As String, Optional Suppr As Boolean)
'Cria um arquivo de backup
Dim B As String
Dim NbTour As Long
Dim Nb As Long
Open Ancien For Binary As #1
Open Nouveau For Binary As #2
B = String$(512, " ")
NbTour = LOF(1) 512
Do
If Nb = NbTour Then
B = String$(LOF(1) - NbTour * 512, " ")
ElseIf Nb > NbTour Then
Exit Do
End If
Nb = Nb + 1
Get #1, , B
Put #2, , B
Loop
Close #1
Close #2
If Suppr = True Then Kill Ancien
End Sub
Private Sub CommandButton1_Click()
DesprotegeVBA
End Sub
