禁止SHIFT键使用(设置启动选项框)-沈军专栏

'以下代码中介绍如何禁止和允许“SHIFT”键的使用，这些代码都是控制ACCESS应用程序中菜单栏-工具-启动子菜单选项中的值，在启动选项窗口中我们虽看不到这一项，但仍然是有效的。

'Me.UserPassWord1是建立在一个特别窗体上的控制（复选框），在这个特别窗体打开的时候需要输入自制的密码方可打开。当访问密码正确时，显示这个控件并由自己控制设置。当选定它时，允许SHIFT键使用；相反，禁止SHIFT键使用。

Sub SetStartupProperties()
    Const DB_Text As Long = 10
    Const DB_Boolean As Long = 1
    If Me.UserPassWord1 = -1 Then
        ChangeProperty "StartUpMenuBar", DB_Text, ""
        ChangeProperty "AppTitle", DB_Text, ""
        ChangeProperty "StartupShowDBWindow", DB_Boolean, True
        ChangeProperty "StartupShowStatusBar", DB_Boolean, True
        ChangeProperty "AllowBuiltinToolbars", DB_Boolean, True
        ChangeProperty "AllowFullMenus", DB_Boolean, True
        ChangeProperty "AllowBreakIntoCode", DB_Boolean, True
        ChangeProperty "AllowSpecialKeys", DB_Boolean, True ‘允许SHIFT键使用有效
        ChangeProperty "AllowToolbarchanges", DB_Boolean, True
        ChangeProperty "Allowshortcutmenus", DB_Boolean, True
        ChangeProperty "AppIcon", DB_Text, ""

        ChangeProperty "AllowBypassKey", DB_Boolean, True
    Else
        ChangeProperty "StartUpMenuBar", DB_Text, "主控菜单"
        ChangeProperty "AppTitle", DB_Text, "集运管理"
        ChangeProperty "StartupShowDBWindow", DB_Boolean, False
        ChangeProperty "StartupShowStatusBar", DB_Boolean, False
        ChangeProperty "AllowBuiltinToolbars", DB_Boolean, False
        ChangeProperty "AllowFullMenus", DB_Boolean, False
        ChangeProperty "AllowBreakIntoCode", DB_Boolean, False
        ChangeProperty "AllowSpecialKeys", DB_Boolean, False ’禁止SHIFT键使用无效
        ChangeProperty "AllowToolbarchanges", DB_Boolean, False
        ChangeProperty "Allowshortcutmenus", DB_Boolean, False
        ChangeProperty "AppIcon", DB_Text, Application.CurrentProject.Path & "\coth.ico"    '"e:\contwork\coth.ico"

ChangeProperty "AllowBypassKey", DB_Boolean, False
End If
End Sub

Function ChangeProperty(strPropName As String, varPropType As Variant, varPropValue As Variant) As Integer
Dim dbs As Object, prp As Variant
Const conPropNotFoundError = 3270

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

Change_Bye:
Exit Function

Change_Err:
    If Err = conPropNotFoundError Then
        Set prp = dbs.CreateProperty(strPropName, varPropType, varPropValue)
        dbs.Properties.Append prp
        Resume Next
    Else
        ChangeProperty = False
        Resume Change_Bye
    End If
End Function