一、打开一个带有密码的数据库
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
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
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货