Just paste this code into any class and change the name of the class to cDBPassword. Be sure to also include the code that appeared in issue 86.
'----------------------------------------------------------------------
'
' Module Name: cDBPassword
' Written By: C&D Programming Corp.
' Create Date: 3/99
' Copyright: Copyright 1998-99 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'
'
' This is an enhancement of Issue #86
'
'----------------------------------------------------------------------
'
'
' In order to keep the email down to size we have not
' included the entire class here. You need to include the
' source code from issue number 86 into this class.
' Replace the OpenDatabase routine with
' the one that appears just below this comment.
'
'
Public Function OpenDatabase(Optional bExclusive As Boolean = False, Optional bReadOnly As Boolean = False) As Database
On Error GoTo Handler
Set OpenDatabase = Nothing
CheckWorkspace
If Dir(DatabaseName) = "" Then
CreateDatabase
Else
' always open in shared mode and not readonly
If DatabasePassword <> "" Then
Set OpenDatabase = mwrkDB.OpenDatabase(DatabaseName, bExclusive, bReadOnly, "MS Access;pwd=" & DatabasePassword)
Else
Set OpenDatabase = mwrkDB.OpenDatabase(DatabaseName, bExclusive, bReadOnly)
End If
End If
Exit Function
Handler:
Err.Raise Err.Number, "OpenDatabase", Err.Description
End Function
Public Function HasPassword() As Boolean
Dim db As Database
Dim sPass As String
CheckWorkspace
On Error Resume Next
sPass = DatabasePassword
DatabasePassword = ""
Set db = OpenDatabase(False, False)
' open database returns a 3031 error when the password is invalid,
' meaning a wrong password
If Err = 3031 Then
HasPassword = True
Else
HasPassword = False
End If
DatabasePassword = sPass
Set db = Nothing
End Function
Public Function IsClosed() As Boolean
Dim db As Database
CheckWorkspace
On Error Resume Next
Set db = OpenDatabase(True, False)
' try to open exclusively. If we can't lets assume itis not open.
If Err = 0 Then
IsClosed = True
Else
IsClosed = False
End If
Set db = Nothing
End Function
Public Sub SetDatabasePassword(sNewPassword As String)
On Error GoTo Handler
CheckWorkspace ' setup the workspace.
If HasPassword And DatabasePassword = "" Then
' 3031 is Not a Valid Password error.
Err.Raise 3031, "SetDatabasePassword", "You have not supplied a valid password for accessing the database " & DatabaseName
End If
'
' Check to see if the database can be compacted by making sure it is closed
'
If Not IsClosed Then
Err.Raise Err.Number, "SetDatabasePassword", "Can not open database exclusively, please make sure nobody else is using " & _
"this software before you reindex the database. The database might also be " & _
"marked readonly." & vbCr & vbCr & _
"Error: " & Err.Description, vbOKOnly
End If
' if the current database has a password then just modify the password on the database
Dim db As Database
Set db = OpenDatabase(True)
db.NewPassword DatabasePassword, sNewPassword
DatabasePassword = sNewPassword
db.Close
Exit Sub
Handler:
Err.Raise Err.Number, "SetDatabasePassword", Err.Description
End Sub
Public Sub ResetDatabasePassword()
' setting a password to a blank string removes the password completely.
SetDatabasePassword ""
End Sub