如何实现启用和禁用SHIFT

时　间:2009-3-3 17:55:00
作 者:沈军
摘　要:ACCESS应用程序编制完成后，封装自己的应用程序非常重要。一般我采取的方法如下：
    1、设置VB密码；
    2、通过程序禁止或允许“SHIFT”键的使用；
    3、建立后台带有密码的数据库文件，利用自制的程序在前台程序中建立这个联接。
    通过以上方法操作，基本上可以防止一般用户进入到自己数据库文件内部。
正　文:

'以下代码中介绍如何禁止和允许“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