NOTE: There are hidden characters in this html file for spacing and other purposes. Be wary about importing the code text here directly into your VBA module.

The following code checks the database to see if it is an .MDE file, and, if so, locks it up (please do not confuse this strategy with establishing security via Users and Groups). Conversely, it will try to unlock any .MDB file that accidentally got locked up - success depending on how the file got locked up in the first place.

You place the code in your MDB file. However, when you make an MDE file from the MDB file the code kicks in when you open the MDE file. When the MDE file is first opened, the code sets the locks in place but the MDE file is still unlocked. The second time the MDE file opens, it is locked.

As always, try this code out on a test database to be sure it works properly before using it in a mission critical database. Also remember to twice open and close the MDE file yourself so you know for sure it will be locked when the end user opens it.

Note: This ADO code is for Access 2000 and 2002 databases only.

All the code goes in the same VBA module and resembles, in great part, the ADO code in the Security Tips section. Again, great chunks of this code c an be found in the Access 2000 or 2002 Developers Handbook by Litwin, Getz, and Gunderloy. I highly recommend serious developers purchase the two volume set from SYBEX as I find it indispensable.

========================================================
========================================================
 

Option Compare Database 'Use database order for string comparisons
Option Explicit

Dim mblnSpecialKeysAllowed As Boolean

========================================================
' The function AmI_MDE() is called by the autoexec macro as the database opens

========================================================

Function AmI_MDE()

Dim dbs As Object
Set dbs = CurrentDb

' Call the function to see if the current Db is an MDE file
If IsItMDE(dbs) Then
' If so, lock it up
Call LockDB
Else
' Otherwise, try to unlock it.
Call UnLockDb
End If

OpenDb_Exit:

Err = 0
On Error GoTo 0
Exit Function

OpenDb_Err:
' Place your error trap here
Resume OpenDb_Exit

End Function

========================================================

Function IsItMDE(dbs As Object) As Boolean

Dim strMDE As String

On Error Resume Next

' All MDE databases have a string property set to "T" if the database is an MDE file. So we check for the value of this property.

strMDE = dbs.Properties("MDE")

If Err = 0 And strMDE = "T" Then
' This is an MDE database.
IsItMDE = True
Else
IsItMDE = False
End If

OpenDb_Exit:

Err = 0
On Error GoTo 0
Exit Function

OpenDb_Err:
' Place your error trap here
Resume OpenDb_Exit

End Function

===================================================

Function LockDB() As Boolean

On Error GoTo LockDb_Err

Const DB_Text As Long = 10
Const DB_Boolean As Long = 1

' This line of code checks to see if the AllowSpecialKeys property is true
' or false. . If it is True, then the database needs to be locked up.

 If TestDBProperty("AllowSpecialKeys") Then

' These next lines of code set to True the various properties
' we wish to activate in the MFE database. They call the code in the
function "ChangeProperty"

Call ChangeProperty("StartupShowDBWindow", DB_Boolean, False)
Call ChangeProperty("StartupShowStatusBar", DB_Boolean, False)
Call ChangeProperty("AllowBuiltinToolbars", DB_Boolean, False)
Call ChangeProperty("AllowFullMenus", DB_Boolean, False)
Call ChangeProperty("AllowBreakIntoCode", DB_Boolean, False)
Call ChangeProperty("AllowSpecialKeys", DB_Boolean, False)
Call ChangeProperty("AllowBypassKey", DB_Boolean, False)
Call ChangeProperty("AllowShortcutMenus", DB_Boolean, False)
Call ChangeProperty("AllowToolbarChanges", DB_Boolean, False)

' I want to make sure these toolbars do not appear at startup.

DoCmd.ShowToolbar "Menu Bar", acToolbarNo
DoCmd.ShowToolbar "Database", acToolbarNo
End if
LockDB = True

Err = 0
On Error GoTo 0
Exit Function

LockDb_Err:
' Place your error trap here
Resume LockDb_Exit

End Function

===================================================

Function UnLockDb() As Boolean

On Error GoTo UnLockDb_Err

' This line of code checks to see if the AllowSpecialKeys property is true
' or false. If it is False, then the database needs to be unlocked.

 If Not TestDBProperty("AllowSpecialKeys") Then

' These next lines of code set to True the various properties
' we wish to activate in the MFE database. They call the code in the
function "ChangeProperty"

Call ChangeProperty("StartUpShowDBWindow", DB_Boolean, True)
Call ChangeProperty("StartupShowStatusBar", DB_Boolean, True)
Call ChangeProperty("AllowBuiltInToolbars", DB_Boolean, True)
Call ChangeProperty("AllowFullMenus", DB_Boolean, True)
Call ChangeProperty("AllowBreakIntoCode", DB_Boolean, True)
Call ChangeProperty("AllowSpecialKeys", DB_Boolean, True)
Call ChangeProperty("AllowBypassKey", DB_Boolean, True)
Call ChangeProperty("AllowToolbarChanges", DB_Boolean, True)
Call ChangeProperty("AllowShortcutMenus", DB_Boolean, True)

' I want to make sure these toolbars appear at startup.

DoCmd.ShowToolbar "Menu Bar", acToolbarYes
DoCmd.ShowToolbar "Database", acToolbarYes
End If
UnLockDb = True

UnLockDb_Exit:

Err = 0
On Error GoTo 0
Exit Function

UnLockDb_Err:
' Place your error trap here
Resume UnLockDb_Exit

End Function

===================================================

Function ChangeProperty(strPropName As String, varPropType As Variant, varPropValue As Variant) As Integer

On Error GoTo ChangeProperty_Err

' This function does two things:
'1) It sets the property to True or False
'2) If the property is not found, it creates the property and then sets the value

Dim dbs As Object
Dim prp As Variant
Const PropertyNotFoundError = 3270

Set dbs = CurrentDb
On Error GoTo ChangeProperty_Err
dbs.Properties(strPropName) = varPropValue
ChangeProperty = True

ChangeProperty_Exit:

Err = 0
On Error GoTo 0
Exit Function

ChangeProperty_Err:

If Err = PropertyNotFoundError Then ' Property not found.
Set prp = dbs.CreateProperty(strPropName, varPropType, varPropValue)
dbs.Properties.Append prp
Resume Next
Else
' Place your error trap here
Resume ChangeProperty_Exit
End If

End Function

===================================================

Function TestDBProperty(strProperty As String) As Boolean

On Error GoTo TestDBProperty_Err

' This function returns the value of the property being inquired about.

Dim db As Object
Dim prpNew As Property
Dim strMsg As String
Const PropertyNotFoundError = 3270

Set db = CurrentDb()

' If the property exists and is set to True, TestDBProperty = True.
' If the property does not exist or is set to False, TestDBProperty remains False.

TestDBProperty = db.Properties(strProperty)

TestDBProperty_Exit:

On Error Resume Next
Set db = Nothing
Err = 0
On Error GoTo 0
Exit Function

TestDBProperty_Err:

If Err = PropertyNotFoundError Then ' err = 3270, property not found.
strMsg = "Property tested does not yet exist." & vbLf & vbLf
strMsg = strMsg & "You will be asked if you want to unlock the database." & vbLf & vbLf
strMsg = strMsg & "Click YES." & vbLf & vbLf
strMsg = strMsg & "The property will then be created and the database will remain unlocked."
MsgBox strMsg, vbOKOnly + vbInformation
Else
' Place your error trap here
End If
Resume TestDBProperty_Exit

End Function

================================================================

Malcolm Anderson, 11/20/2003