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

Changing a User Password

   <source lang="vb">

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

</source>
   
  

Deleting a Database Password with SQL command

   <source lang="vb">

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

</source>
   
  

Embedding a Database Password in Code

   <source lang="vb">

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

</source>
   
  

Requiring Password Validation

   <source lang="vb">

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

</source>
   
  

Setting a Database Password

   <source lang="vb">

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

</source>
   
  

Setting a Database Password with SQL command

   <source lang="vb">

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

</source>