VBA/Excel/Access/Word/Access/Database Password

Changing a User Password

 
Sub Change_UserPassword()
    Dim cat As ADOX.Catalog
    Dim strDB As String
    Dim strSysDb As String
    On Error GoTo ErrorHandle
    strDB = CurrentProject.Path & "\mydb.mdb"
    strSysDb = "C:\System.mdw"
    Set cat = New ADOX.Catalog
    With cat
        .ActiveConnection = "Provider="Microsoft.Jet.OLEDB.4.0";" & _
                            "Data Source="" & strDB & "";" & _
                            "Jet OLEDB:System Database="" & strSysDb & "";" & _
                            "User Id=Admin;Password=;"
        .Users("Admin").ChangePassword " ", "secret"
    End With
ExitHere:
    Set cat = Nothing
    Exit Sub
ErrorHandle:
    MsgBox Err.Description
    GoTo ExitHere
End Sub

Deleting a Database Password with SQL command

 
Sub DeleteDbPassword() 
    Dim conn As ADODB.Connection 
    Dim strPath As String 
    Dim strPass As String 
    On Error GoTo ErrorHandler 
    strPath = CurrentProject.Path 
    strPass = "secret" 
    Set conn = New ADODB.Connection 
    With conn 
        .Mode = adModeShareExclusive 
        .Open "Provider = Microsoft.Jet.OleDb.4.0;" & _ 
            "Data Source=" & strPath & "\mydb.mdb;" _ 
            & "Jet OLEDB:Database Password = " & strPass 
        .Execute "ALTER DATABASE PASSWORD null secret" 
    End With 
ExitHere: 
    If Not conn Is Nothing Then 
        If conn.State = adStateOpen Then conn.Close 
    End If 
    Set conn = Nothing 
    Exit Sub 
ErrorHandler: 
    Debug.Print Err.Number & ":" & Err.Description 
    Resume ExitHere 
End Sub

Embedding a Database Password in Code

 
Sub LinkToSecured()
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = CurrentProject.Connection
    Set tbl = New ADOX.Table
    tbl.Name = "tblLinkedTable"
    Set tbl.ParentCatalog = cat
    tbl.Properties("Jet OLEDB:Create Link") = True
    tbl.Properties("Jet OLEDB:Link Provider String") = "ODBC" & _
        ";DATABASE=Pubs" & _
        ";UID=SA" & _
        ";PWD=" & _
        ";DSN=PublisherData"
    tbl.Properties("Jet OLEDB:Remote Table Name") = "Employees"
    cat.Tables.Append tbl
End Sub

Requiring Password Validation

 
Sub ReallySecure()
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim strPassword As String
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = CurrentProject.Connection
    Set tbl = New ADOX.Table
    tbl.Name = "tblLinkedTable"
    Set tbl.ParentCatalog = cat
    strPassword = "pass"
    tbl.Properties("Jet OLEDB:Create Link") = True
    tbl.Properties("Jet OLEDB:Link Provider String") = "ODBC" & _
        ";DATABASE=Pubs" & _
        ";UID=SA" & _
        ";PWD=" & strPassword & _
        ";DSN=YourData"
    tbl.Properties("Jet OLEDB:Remote Table Name") = "Employees"
    cat.Tables.Append tbl
End Sub

Setting a Database Password

 
Sub Change_DBPassword() 
    Dim jetEng As JRO.JetEngine 
    Dim strCompactFrom As String 
    Dim strCompactTo As String 
    Dim strPath As String 
    On Error GoTo ErrHandle 
    strPath = CurrentProject.Path & "\" 
    strCompactFrom = "mydb.mdb" 
    strCompactTo = "mydb_.mdb" 
    Set jetEng = New JRO.JetEngine 
    jetEng.rupactDatabase "Data Source=" & strPath & strCompactFrom & ";", _ 
                           "Data Source=" & strPath & strCompactTo & ";" & _ 
                           "Jet OLEDB:Database Password=welcome" 
ExitHere: 
    Set jetEng = Nothing 
    Exit Sub 
ErrHandle: 
    If Err.Number = -2147217897 Then 
        Kill strPath & strCompactTo 
        Resume 
    Else 
        MsgBox Err.Number & ": " & Err.Description 
        Resume ExitHere 
    End If 
End Sub

Setting a Database Password with SQL command

 
Sub SetDbPassword() 
    Dim conn As ADODB.Connection 
    Dim strPath As String 
    On Error GoTo ErrorHandler 
    strPath = CurrentProject.Path 
    Set conn = New ADODB.Connection 
    With conn 
        .Mode = adModeShareExclusive 
        .Open "Provider = Microsoft.Jet.OLEDB.4.0;" & _ 
                    "Data Source=" & strPath & "\mydb.mdb;" 
        .Execute "ALTER DATABASE PASSWORD secret null " 
    End With 
 ExitHere: 
     If Not conn Is Nothing Then
         If conn.State = adStateOpen Then conn.Close 
     End If 
     Set conn = Nothing 
     Exit Sub 
 ErrorHandler: 
     Debug.Print Err.Number & ":" & Err.Description 
     Resume ExitHere 
End Sub