A personal repository of random information in compensation for a fatigued biological computer
Breaded IT » MS Access / SQL Server reminders » Securing Access
http://support.microsoft.com/kb/826765: CurrentProject.Properties.Add "AllowBypassKey", False
http://www.databasedev.co.uk/disable_shift_bypass.html
bAdmin = IIf(GetValue("EXEC GetAdmin") = "Y", True, False)
If Not bAdmin Then
Dim x As Integer
For x = 1 To Application.CommandBars.Count
Application.CommandBars(x).Enabled = False
' Debug.Print Application.CommandBars(x).Name
Next x
'Application.CommandBars("CustomMenuBar").Enabled = True
'Application.CommandBars("CustomMenuBar").Visible = True
Application.CommandBars("CustomMenuBar").Enabled = False
Application.CommandBars("CustomMenuBar").Visible = False
Application.CommandBars("customMenuBar").RowIndex = 1
ChangeProperty "StartUpShowDBWindow", False
ChangeProperty "StartUpShowStatusBar", True
ChangeProperty "AllowBuiltInToolbars", False
ChangeProperty "AllowBreakIntoCode", False
ChangeProperty "AllowToolbarChanges", False
ChangeProperty "AllowSpecialKeys", False
ChangeProperty "AllowBypassKey", False
ChangeProperty "AppTitle", MsgBoxTitle
ChangeProperty "AllowShortcutMenus", False
ChangeProperty "AllowFullMenus", False
Else
Application.CommandBars("Menu Bar").Enabled = True
Application.CommandBars("Menu Bar").Visible = True
ChangeProperty "StartUpShowDBWindow", True
ChangeProperty "StartUpShowStatusBar", True
ChangeProperty "AllowBuiltInToolbars", True
ChangeProperty "AllowBreakIntoCode", True
ChangeProperty "AllowToolbarChanges", True
ChangeProperty "AllowSpecialKeys", True
ChangeProperty "AllowBypassKey", True
ChangeProperty "AppTitle", MsgBoxTitle
ChangeProperty "AllowShortcutMenus", True
ChangeProperty "AllowFullMenus", True
MsgBox "Start Again for security changes to take effect."
End If
Function ChangeProperty(strPropName As String, varPropValue As Variant) As Integer
On Error GoTo ChangeProperty_Error
Dim bFoundProperty As Boolean
Dim x As Integer
bFoundProperty = False
For x = 0 To CurrentProject.Properties.Count - 1
If CurrentProject.Properties(x).Name = strPropName Then
bFoundProperty = True
x = CurrentProject.Properties.Count - 1
End If
Next x
If bFoundProperty Then
CurrentProject.Properties(strPropName).Value = varPropValue
Else
CurrentProject.Properties.Add strPropName, varPropValue
End If
Exit Function
ChangeProperty_Error:
Result = MsgBox("Error " & Err.Number & " '" & Err.Description & "' occured in ChangeProperty." & vbCrLf & "Click OK to retry or Cancel to Quit.", vbCritical + vbOKCancel + vbDefaultButton1)
If Result = vbOK Then
Resume
Else
End
End If
End Function