一、打开一个带有密码的数据库
Public Function OpenPasswordProtectedDatabase(DBPath As String, _
Password As String) As Object
'Usage: Open Password protected database
'Parameters: DBPath: Full Path to Access Database
'Password: the Password
'returns the database, in it's open state if successful.
'Otherwise return value will evalute to nothing
On Error Resume Next
Dim db As DAO.Database
Set db = DAO.OpenDatabase(DBPath, False, False, _
    ";pwd=" & Password)
If Err.Number = 0 Then
    Set OpenPasswordProtectedDatabase = db
Else
    Set OpenPasswordProtectedDatabase = Nothing
End If
End Function
二、为数据库添加密码
Public Function SetDatabasePassword(DBPath As String, _
newPassword As String) As Boolean
    
'Usage: Password protect a database that previously had no 
'password
'Parameters: sDBPath: Full Path to Access Database
'newPassword: the password
'returns true on success false otherwise
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 "", newPassword
SetDatabasePassword = Err.Number = 0
db.Close
End Function
三、修改已有数据库的密码
Public Function ChangeDatabasePassword(DBPath As String, _
newPassword As String, oldPassWord As String) As Boolean
    
'Usage: Change DatabasePassword
'Parameters: sDBPath: Full Path to Access Database
'newPassword: the password
'oldPassword: the previous password
'returns true on success false otherwise
If Dir(DBPath) = "" Then Exit Function
Dim db As DAO.Database
On Error Resume Next
Set db = OpenDatabase(DBPath, True, False, ";pwd=" & oldPassWord)
If Err.Number <> 0 Then Exit Function
db.newPassword oldPassWord, newPassword
ChangeDatabasePassword = Err.Number = 0
db.Close
End Function
四、检查MS Excel或Access是否具有密码保护 
Public Function Password_Check(Path As String) As String
Dim db As DAO.Database
if dir(Path) = "" then
'Return 0 if file does not exist
   Password_Check = "0"
   Exit Function
end if
If Right(Path, 3) = "mdb" Then
    On Error GoTo errorline
    Set db = OpenDatabase(Path)
    Password_Check = "False"
    db.Close
    Exit Function
ElseIf Right(Path, 3) = "xls" Then
    On Error GoTo errorline
    Set db = OpenDatabase(Path, True, False, "Excel 5.0")
    Password_Check = "False"
    db.Close
    Exit Function
Else
    'Assume it's not a valid file
    'if correct extension is not present
    Password_Check = "0"
    Exit Function
End If
errorline:
    
    Password_Check = "True"
    Exit Function
End Function