frmpermission.frm

中小型图书会员制租赁管理系统,采用ACCESS数据库。

         Height          =   255
         Index           =   1
         Left            =   3240
         TabIndex        =   10
         Top             =   840
         Width           =   375
      End
      Begin VB.CheckBox Check1 
         Height          =   255
         Index           =   0
         Left            =   2040
         TabIndex        =   9
         Top             =   840
         Width           =   375
      End
      Begin VB.Label Label9 
         AutoSize        =   -1  'True
         Caption         =   "6"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   195
         Index           =   5
         Left            =   720
         TabIndex        =   56
         Top             =   3270
         Width           =   120
      End
      Begin VB.Label Label9 
         AutoSize        =   -1  'True
         Caption         =   "5"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   195
         Index           =   4
         Left            =   720
         TabIndex        =   55
         Top             =   2800
         Width           =   120
      End
      Begin VB.Label Label9 
         AutoSize        =   -1  'True
         Caption         =   "4"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   195
         Index           =   3
         Left            =   720
         TabIndex        =   54
         Top             =   2310
         Width           =   120
      End
      Begin VB.Label Label9 
         AutoSize        =   -1  'True
         Caption         =   "3"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   195
         Index           =   2
         Left            =   720
         TabIndex        =   53
         Top             =   1830
         Width           =   120
      End
      Begin VB.Label Label9 
         AutoSize        =   -1  'True
         Caption         =   "2"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   195
         Index           =   1
         Left            =   720
         TabIndex        =   52
         Top             =   1350
         Width           =   120
      End
      Begin VB.Label Label9 
         AutoSize        =   -1  'True
         Caption         =   "1"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   195
         Index           =   0
         Left            =   720
         TabIndex        =   51
         Top             =   860
         Width           =   120
      End
      Begin VB.Label Label8 
         AutoSize        =   -1  'True
         Caption         =   "权限等级"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   195
         Left            =   360
         TabIndex        =   8
         Top             =   360
         Width           =   780
      End
      Begin VB.Label Label7 
         AutoSize        =   -1  'True
         Caption         =   "回收项目"
         Height          =   180
         Left            =   7680
         TabIndex        =   7
         Top             =   360
         Width           =   720
      End
      Begin VB.Label Label6 
         AutoSize        =   -1  'True
         Caption         =   "系统用户"
         Height          =   180
         Left            =   6600
         TabIndex        =   6
         Top             =   360
         Width           =   720
      End
      Begin VB.Label Label5 
         AutoSize        =   -1  'True
         Caption         =   "会员权限"
         Height          =   180
         Left            =   5640
         TabIndex        =   5
         Top             =   360
         Width           =   720
      End
      Begin VB.Label Label4 
         AutoSize        =   -1  'True
         Caption         =   "Items"
         Height          =   195
         Left            =   4920
         TabIndex        =   4
         Top             =   360
         Width           =   375
      End
      Begin VB.Label Label3 
         AutoSize        =   -1  'True
         Caption         =   "搜索"
         Height          =   180
         Left            =   4080
         TabIndex        =   3
         Top             =   360
         Width           =   360
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         Caption         =   "报表统计"
         Height          =   180
         Left            =   3120
         TabIndex        =   2
         Top             =   360
         Width           =   720
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "交易/业务（租赁）"
         Height          =   180
         Left            =   1440
         TabIndex        =   1
         Top             =   360
         Width           =   1530
      End
   End
End
Attribute VB_Name = "frmPermission"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Sub CreateDB()
On Error Resume Next
Dim vr_engine As VRENTAL_ENGINE
Set vr_engine = New VRENTAL_ENGINE
Dim daoWS As dao.Workspace
Dim daoDB As dao.Database
Dim daoTable As New dao.TableDef
Dim daoField As New dao.Field
Set daoWS = DBEngine.Workspaces(0)

' Create database
 Set daoDB = daoWS.CreateDatabase(App.Path & "\Permission.mdb", dbLangGeneral, dbVersion40)

' Create Table
 Set daoTable = daoDB.CreateTableDef("PermissionTable")

' Create Fields
Set daoField = daoTable.CreateField("会员权限", dbInteger)

' Append field to table
daoTable.Fields.Append daoField

Set daoField = daoTable.CreateField("Permissions", dbText, 255)

' Append field to table
daoTable.Fields.Append daoField

' Append table to database
daoDB.TableDefs.Append daoTable

' Clean up objects
Set daoField = Nothing
Set daoTable = Nothing
Set daoDB = Nothing
Set daoWS = Nothing
Call vr_engine.SetDatabasePassword(App.Path & "\Permission.mdb", "AdmiN")
End Sub
Sub initDB()
Dim loop1 As Integer
Dim db As Database
Dim rec As Recordset
Set db = OpenDatabase(App.Path & "\Permission.mdb" _
             , False, False, ";pwd=AdmiN")
Set rec = db.OpenRecordset("PermissionTable", dbOpenTable)

For loop1 = 1 To 6
    rec.AddNew
    rec.Fields("会员权限") = loop1
    rec.Fields("Permissions") = "0000000"
    rec.Update
Next loop1

Set db = Nothing
Set rec = Nothing
End Sub
Sub UpdateDB()

Dim loop1, loop3, counter As Integer
Dim strn As String
Dim db As Database
Dim rec As Recordset
Set db = OpenDatabase(App.Path & "\Permission.mdb" _
             , False, False, ";pwd=AdmiN")
Set rec = db.OpenRecordset("PermissionTable", dbOpenTable)
    counter = 0
    rec.MoveFirst
    strn = ""
For loop1 = 1 To 6
      rec.Edit
      For loop3 = 1 To 7
        strn = strn & Trim(str(Check1(counter + loop3 - 1).Value))
      Next loop3
      rec.Fields("Permissions") = strn
      strn = ""
      rec.Update
      counter = counter + 7
    If rec.EOF = False Then rec.MoveNext
Next loop1

Set db = Nothing
Set rec = Nothing
End Sub
Sub loadvaluesToChkbox()
Dim loop1, loop2, counter As Integer
Dim str As String
Dim db As Database
Dim rec As Recordset
Set db = OpenDatabase(App.Path & "\Permission.mdb" _
             , False, False, ";pwd=AdmiN")
Set rec = db.OpenRecordset("PermissionTable", dbOpenTable)
counter = 0
    rec.MoveFirst
For loop1 = 1 To 6
    str = Trim(rec.Fields("Permissions"))
    For loop2 = 1 To 7
        Check1(counter).Value = Int(Val(Mid(str, loop2, 1)))
        counter = counter + 1
    Next loop2
    If rec.EOF = False Then rec.MoveNext
Next loop1

Set db = Nothing
Set rec = Nothing
End Sub



Private Sub Check1_Click(Index As Integer)
Check1(40).Value = 1
End Sub

Private Sub cmdSaveSettings_Click()
Call UpdateDB
MsgBox "设置已经更改！", vbInformation, "更改权限"
Check1(0).SetFocus
End Sub
Private Sub Form_Activate()
Dim vr_engine As VRENTAL_ENGINE
Set vr_engine = New VRENTAL_ENGINE
Dim loop1 As Integer
' Check if file exist
If vr_engine.ReportFileStatus(App.Path & "\Permission.mdb") = False Then
    Call CreateDB
    Call initDB
    Call loadvaluesToChkbox
End If
'Save to DB
Call loadvaluesToChkbox
Check1(0).SetFocus
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyEscape Then Unload Me
End Sub