Set db = area.OpenDatabase(App.Path & "\teste.mdb", True, False, ";PWD=" & senha_antiga)
'aqui usamos o metodo newpassword para mudar a senha
db.NewPassword senha_antiga, senha_nova

Set db = area.OpenDatabase(App.Path & "\teste.mdb", False, False, ";PWD=" & password)
MsgBox "Senha Alterada com sucesso !!! "

Public Function SetDbSenha(DBPath As String, novaSenha As String) As Boolean

If Dir(DBPath) = "" Then Exit Function

Dim db As DAO.Database

On Error Resume Next

Set db = OpenDatabase(DBPath, True)

If Err.Number <> 0 Then Exit Function

db.newPassword "", novaSenha

SetDbSenha = Err.Number = 0

db.Close

End Function

Dim area As Workspace
Dim db As Database
Dim username As String
Dim password As String
Option Explicit

Private Sub Command1_Click()
'atençao para proteger/desproteger seu mdb abra o arquivo no access
'com acesso exclusivo e em segurança ative/desative a senha
'a senha usada aqui é a palavra:  password (minúsculas)

On Error GoTo trata_erro

'indica aonde esta o arquivo de segurança
DBEngine.SystemDB = App.Path & "\system.mdw"

If Text1.Text = "" Then
    MsgBox "Informe nome do usuario"
    Text1.SetFocus
    Exit Sub
End If

'variáveis públicas
username = Text1.Text 'o nome do usuario existe apenas para voce controlar o login
password = Text2.Text 'senha do banco de dados

'abre area de trabalho padrao
Set area = DBEngine.Workspaces(0)
'Verifique a senha do banco de dados para proteger seus dados
Set db = area.OpenDatabase(App.Path & "\teste.mdb", False, False, ";PWD=" & password)
 
MsgBox "A senha esta correta , entre ... ", vbExclamation, "Login da base de dados"

Hide
Exit Sub

'tratamento de erros
trata_erro:
     If Err.Number = 3029 Or Err.Number = 3031 Then
       MsgBox "Senha/Usuario Inválido(s) !!!", , "ATENÇÃO"
       Text1.Text = ""
       Text2.Text = ""
     Else
       MsgBox Errors(0).Description, , "ATENÇÃO"
     End If
     Exit Sub
End Sub

Private Sub Command2_Click()
   End
End Sub

Option Compare Binary
Option Explicit

Public Function StPasswordOfStDatabase(stDatabase As String) As String
    Dim hFile As Integer
    Dim ich As Integer
    Dim stBuffer As String
    Dim rgbytRaw() As Byte
    Dim rgbytPassword() As Byte
    Dim rgbytNoPassword() As Byte
    
    ' Create the byte array with the 20 bytes that are present when there
    ' is no database password
    rgbytNoPassword = ChrB(134) & ChrB(251) & ChrB(236) & ChrB(55) & ChrB(93) & _
                                ChrB(68) & ChrB(156) & ChrB(250) & ChrB(198) & ChrB(94) & _
                                ChrB(40) & ChrB(230) & ChrB(19) & ChrB(182) & ChrB(138) & _
                                ChrB(96) & ChrB(84) & ChrB(148) & ChrB(123) & ChrB(54)
                                
    ' Grab the 20 bytes from the real file whose password
    ' we are supposed to retrieve
    hFile = FreeFile
    Open stDatabase For Binary As #hFile
    Seek #hFile, 66 + 1
    rgbytRaw = InputB(20, #hFile)
    Close #hFile
    
    ' Enough prep, lets get the password now.
    ReDim rgbytPassword(0 To 19)
    For ich = 0 To 19
        rgbytPassword(ich) = rgbytRaw(ich) Xor rgbytNoPassword(ich)
    Next ich

    ' Add a trailing Null so one will always be found, even if the password is 20
    ' characters. Then grab up to the first null we find and return the password
stBuffer = StrConv(rgbytPassword, vbUnicode) & vbNullChar
StPasswordOfStDatabase = Left$(stBuffer, InStr(1, stBuffer, vbNullChar, vbBinaryCompare) - 1)
End Function

Private Const cintAcc97PwdOffset As Integer = &H43

Public Sub smsAcc97PwdClear(ByVal vstrMdbPath As String)

    On Error GoTo smsAcc97PwdClear_Err
    
    Dim intFn As Integer
    Dim strClearPwd As String
    
    strClearPwd = Chr(&H86) & Chr(&HFB) & Chr(&HEC) & Chr(&H37) & _
                  Chr(&H5D) & Chr(&H44) & Chr(&H9C) & Chr(&HFA) & _
                  Chr(&HC6) & Chr(&H5E) & Chr(&H28) & Chr(&HE6) & _
                  Chr(&H13)  ' trailing baker's dozen ;-)
                  
    intFn = FreeFile
    Open vstrMdbPath For Binary Access Write As #intFn
    Put #intFn, cintAcc97PwdOffset, strClearPwd
    Close intFn

smsAcc97PwdClear_Exit:
    Exit Sub
smsAcc97PwdClear_Err:
    MsgBox "smsAcc97PwdClear: Err = " & Err & " - " & Err.Description
    Resume smsAcc97PwdClear_Exit
End Sub

Function AccessPassword(Byval Filename As String) As String

    Dim MaxSize, NextChar, MyChar, secretpos,TempPwd 
    Dim secret(13) 

    secret(0) = (&H86) 
    secret(1) = (&HFB) 
    secret(2) = (&HEC) 
    secret(3) = (&H37) 
    secret(4) = (&H5D) 
    secret(5) = (&H44) 
    secret(6) = (&H9C) 
    secret(7) = (&HFA) 
    secret(8) = (&HC6) 
    secret(9) = (&H5E) 
    secret(10) = (&H28) 
    secret(11) = (&HE6) 
    secret(12) = (&H13) 

    secretpos = 0 

    Open Filename For Input As #1 ' Abre o arquivo para escrita


    For NextChar = 67 To 79 Step 1 'Le a senha criptografada 
        Seek #1, NextChar ' define a posição
        MyChar = Input(1, #1) ' Lê o caractere. 
        TempPwd = TempPwd & Chr(Asc(MyChar) Xor secret(secretpos)) 'Faz a decriptação
        secretpos = secretpos + 1 'incrementa o ponteiro 
    Next NextChar 

    Close #1 ' fecha o arquivo. 
    AccessPassword = TempPwd

End Function

Sub RecoverDb ()
    On Error GoTo RecoverDb_err:
    DoCmd Hourglass True
    Const strFile = "recover.mdb"
    Dim intI as integer
    Dim strTemp
    Dim dbTemp as Database
    If Not Len(Dir(strFile)) = 0 Then
        Kill strFile
    End if
    Set dbTemp = DBEngine(0).CreateDatabase(strFile, DB_LANG_GENERAL)   
    Set dbTemp = DBEngine(0)(0)
    For intI = 0 To dbTemp.TableDefs.count - 1
        strTemp = dbTemp.TableDefs(intI).name
	'Don't copy system tables
        If not Mid(strTemp, 2, 3) = "Sys" Then DoCmd CopyObject strFile, strTemp, A_TABLE, strTemp
    Next intI
    For intI = 0 To dbTemp.QueryDefs.count - 1
        strTemp = dbTemp.QueryDefs(intI).name
        DoCmd CopyObject strFile, strTemp, A_QUERY, strTemp
    Next intI
    For intI = 0 To dbTemp.containers("Forms").documents.count - 1
        strTemp = dbTemp.containers("Forms").documents(intI).name
        DoCmd CopyObject strFile, strTemp, A_FORM, strTemp
    Next intI
    For intI = 0 To dbTemp.containers("Reports").documents.count - 1
        strTemp = dbTemp.containers("Reports").documents(intI).name
        DoCmd CopyObject strFile, strTemp, A_REPORT, strTemp
    Next intI
    For intI = 0 To dbTemp.containers("Scripts").documents.count - 1
        strTemp = dbTemp.containers("Scripts").documents(intI).name
        DoCmd CopyObject strFile, strTemp, A_MACRO, strTemp
    Next intI
    For intI = 0 To dbTemp.containers("Modules").documents.count - 1
        strTemp = dbTemp.containers("Modules").documents(intI).name
        DoCmd CopyObject strFile, strTemp, A_MODULE, strTemp
    Next intI
    DoCmd Hourglass False: Beep
    MsgBox "Database recovered to file " & strFile, 64
    Exit Sub
    RecoverDb_Err:
    Select Case Msgbox(Error, 50)
        Case 3 'Abort
             exit sub
        Case 4 'Retry
             Resume
        Case 5 'Ignore
             Resume Next
    End Select
End Sub

Dim n As Long, s1 As String * 1, s2 As String * 1
Dim lsClave As String

Open "c:\laranja.mdb" For Binary As #1
Open text1.text For Binary As #2
Seek #1, &H43
Seek #2, &H43
For n = 1 To 40 Step 2
   s1 = Input(1, 1)
   s2 = Input(1, 2)
   If (Asc(s1) Xor Asc(s2)) <> 0 Then
       lsClave = lsClave & Chr(Asc(s1) Xor Asc(s2))
   End If
   s1 = Input(1, 1) 
   s2 = Input(1, 2) 
Next
Close 1
Close 2
MsgBox "A senha é...:" & lsClave

End Sub

Quer migrar para o VB .NET ?

• Veja mais sistemas completos para a plataforma .NET no Super DVD .NET , confira...

• Curso Básico VB .NET - Vídeo Aulas

Quer aprender C# ??

• Chegou o Super DVD C# com exclusivo material de suporte e vídeo aulas com curso básico sobre C#.

• Curso C# Basico - Video Aulas

Quer aprender os conceitos da Programação Orientada a objetos ?

• Curso Fundamentos da Programação Orientada a Objetos com VB .NET

Quer aprender o gerar relatórios com o ReportViewer no VS 2013 ?

•  Curso - Gerando Relatórios com o ReportViewer no VS 2013 - Vídeo Aulas  

Quer aprender a criar aplicações Web Dinâmicas usando a ASP .NET MVC 5 ?

•  Curso ASP .NET MVC 5 - Vídeo Aulas