vrental_engine.cls

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

 numMonths = (numyears - Int(numyears)) * 365.25 / 30.4583
 GetAge = Int(numyears)
End Function
Function ReportFileStatus(filespec) As Boolean '' Check if file is present 检查文件是否整备就绪
   Dim fso, msg
   Set fso = CreateObject("Scripting.FileSystemObject")
   If (fso.FileExists(filespec)) Then
      msg = -1
   Else
      msg = 0
   End If
   ReportFileStatus = msg
End Function
Function GetDayCount(FirstDate As String, SecondDate As String) As Integer
    GetDayCount = Abs(DateSerial(Year(SecondDate), Format(SecondDate, "MM"), Day(SecondDate)) - DateSerial(Year(FirstDate), Format(FirstDate, "MM"), Day(FirstDate)))
End Function
Function Round(RoundMe, RoundTo) As Double
    Round = Int((RoundMe * 10 ^ RoundTo) + 0.5) / 10 ^ RoundTo
End Function
Sub LoadUsers(lst As ListBox)  '定义过程：连接Users表并往listbox里加载用户名
    On Error GoTo ErrorHandler:
    Dim db As Database
    Dim rec As Recordset
    Dim TDM As Variant
    Dim loop1 As Integer
    lst.Clear
    
    Set db = OpenDatabase(App.Path & "\Database\UsersDB.mdb", False, False, ";pwd=AdmiN")
    Set rec = db.OpenRecordset("Users", dbOpenTable)
    
    rec.MoveFirst
    If rec.RecordCount > 0 Then
        For loop1 = 1 To rec.RecordCount
            TDM = DoEvents()
            lst.AddItem rec.Fields("First Name") & " " & Left(rec.Fields("Middle Name"), 1) & ". " & _
            rec.Fields("姓氏") & " (" & rec.Fields("用户名") & ")"
            rec.MoveNext
        Next loop1
     End If
  db.Close
  Exit Sub
ErrorHandler:
    db.Close
End Sub
Sub getUserInfo(txtUserID As TextBox, txtDateEntered As TextBox, _
                txtUserName As TextBox, txtPassword As TextBox, _
                txtAccessLevel As TextBox, txtFirstName As TextBox, _
                txtMiddleName As TextBox, txtFamilyName As TextBox, _
                txtBirthday As TextBox, txtSex As TextBox, _
                txtHomeAddress As TextBox, txtContactNumber As TextBox, _
                txtComments As TextBox, txtConfirmPassword As TextBox, lst As ListBox)
On Error GoTo Err:
    Dim db As Database
    Dim rec As Recordset
    Dim TDM As Variant
    Dim loop1 As Integer
    Set db = OpenDatabase(App.Path & "\Database\UsersDB.mdb", False, False, ";pwd=AdmiN")
    Set rec = db.OpenRecordset("Users", dbOpenTable) '连接数据库，打开Users表里的数据记录集
    
If rec.BOF = True And rec.EOF = True Then Exit Sub '检查纪录是否存在,不存在则跳出

rec.MoveFirst
    If rec.RecordCount > 0 Then
        For loop1 = 1 To rec.RecordCount
            TDM = DoEvents()
            If lst.Text = rec.Fields("First Name") & " " & Left(rec.Fields("Middle Name"), 1) & ". " & _
                          rec.Fields("姓氏") & " (" & rec.Fields("用户名") & ")" Then
                    txtUserID.Text = rec.Fields("UserID")
                    txtDateEntered.Text = Format(rec.Fields("Date Entered"), "mmm. d, yyyy")
                    txtUserName.Text = rec.Fields("用户名")
                    txtPassword.Text = rec.Fields("密码")
                    txtConfirmPassword.Text = txtPassword.Text
                    txtAccessLevel.Text = rec.Fields("会员权限")
                    txtFirstName.Text = rec.Fields("First Name")
                    txtMiddleName.Text = rec.Fields("Middle Name")
                    txtFamilyName.Text = rec.Fields("姓氏")
                    txtBirthday.Text = Format(rec.Fields("生日"), "mmm. d, yyyy")
                    txtSex.Text = rec.Fields("性别")
                    txtHomeAddress.Text = rec.Fields("家庭住址")
                    txtContactNumber.Text = rec.Fields("联系号码")
                    txtComments.Text = rec.Fields("使用评价")
                    db.Close
                    Exit Sub
            End If
            rec.MoveNext
        Next loop1
     End If
  db.Close
Err:
  txtDateEntered.Text = ""
  txtUserID.Text = ""
End Sub
Function UpdateEditedUsersDB(txtUserName As TextBox, txtPassword As TextBox, _
                txtAccessLevel As TextBox, txtFirstName As TextBox, _
                txtMiddleName As TextBox, txtFamilyName As TextBox, _
                txtBirthday As TextBox, txtSex As TextBox, _
                txtHomeAddress As TextBox, txtContactNumber As TextBox, _
                txtComments As TextBox, lst As ListBox) As Boolean
'On Error GoTo ErrorHandler 如发生错误则跳转到 ErrorHandler
    Dim db As Database
    Dim rec As Recordset
    Dim TDM As Variant
    Dim loop1 As Integer
    
    Set db = OpenDatabase(App.Path & "\Database\UsersDB.mdb", False, False, ";pwd=AdmiN")
             Set rec = db.OpenRecordset("Users", dbOpenTable)
    ''---------------------------------------------
    If rec.BOF = True And rec.EOF = True Then
    rec.AddNew
                 rec.Fields("Date Entered") = Date$
                 rec.Fields("UserID") = 1 '1st record
                 rec.Fields("用户名") = Trim(txtUserName.Text)
                 rec.Fields("密码") = Trim(txtPassword.Text)
                 rec.Fields("会员权限") = Trim(txtAccessLevel.Text)
                 rec.Fields("First Name") = Trim(txtFirstName.Text)
                 rec.Fields("Middle Name") = Trim(txtMiddleName.Text)
                 rec.Fields("姓氏") = Trim(txtFamilyName.Text)
                 rec.Fields("生日") = Trim(txtBirthday.Text)
                 rec.Fields("性别") = Trim(txtSex.Text)
                 rec.Fields("家庭住址") = Trim(txtHomeAddress.Text)
                 rec.Fields("联系号码") = Trim(txtContactNumber.Text)
                 rec.Fields("Comments") = Trim(txtComments.Text)
                 rec.Update  ''Update the recordset
               '' End update fields
               db.Close  '' Close DB
    
    UpdateEditedUsersDB = True
    Exit Function
    End If
    ''---------------------------------------------
    rec.MoveFirst
    '' Start Chk for duplicates sql
    '' End -- chk duplicates
    If rec.RecordCount > 0 Then
        For loop1 = 1 To rec.RecordCount
            TDM = DoEvents()
            If lst.Text = rec.Fields("First Name") & " " & Left(rec.Fields("Middle Name"), 1) & ". " & _
                          rec.Fields("姓氏") & " (" & rec.Fields("用户名") & ")" Then
               '' Start update fields
              
                 rec.Edit
                 rec.Fields("用户名") = Trim(txtUserName.Text)
                 rec.Fields("密码") = Trim(txtPassword.Text)
                 rec.Fields("会员权限") = Trim(txtAccessLevel.Text)
                 rec.Fields("First Name") = Trim(txtFirstName.Text)
                 rec.Fields("Middle Name") = Trim(txtMiddleName.Text)
                 rec.Fields("姓氏") = Trim(txtFamilyName.Text)
                 rec.Fields("生日") = Trim(txtBirthday.Text)
                 rec.Fields("性别") = Trim(txtSex.Text)
                 rec.Fields("家庭住址") = Trim(txtHomeAddress.Text)
                 rec.Fields("联系号码") = Trim(txtContactNumber.Text)
                 rec.Fields("使用评价") = Trim(txtComments.Text)
                 rec.Update  ''Update the recordset
               '' End update fields
               db.Close  '' Close DB
               UpdateEditedUsersDB = True
               Exit Function
            End If
            rec.MoveNext
        Next loop1
     End If
  db.Close
  UpdateEditedUsersDB = True
  Exit Function
ErrorHandler:
  MsgBox "名字已经占用！" & vbCrLf & vbCrLf & "Change your 用户名. ", vbInformation, "Update Error"
UpdateEditedUsersDB = False
End Function
Function AddUserToDB(txtDateEntered As TextBox, txtUserName As TextBox, txtPassword As TextBox, _
                txtAccessLevel As TextBox, txtFirstName As TextBox, _
                txtMiddleName As TextBox, txtFamilyName As TextBox, _
                txtBirthday As TextBox, txtSex As TextBox, _
                txtHomeAddress As TextBox, txtContactNumber As TextBox, _
                txtComments As TextBox) As Boolean
    Dim db As Database
    Dim rec As Recordset
    Dim TDM As Variant
    Dim loop1 As Integer
    Dim AutoNumber As Long
    AutoNumber = 0 ' init to zero
    Dim Valid As Boolean
    Valid = False  ' Init to False
    
    Set db = OpenDatabase(App.Path & "\Database\UsersDB.mdb", False, False, ";pwd=AdmiN")
    Set rec = db.OpenRecordset("Users", dbOpenTable)
     '' Start -- Check for valid "New ID" to avoid duplicates  检查新ID是否合法以避免重复
        If rec.BOF = True And rec.EOF = True Then
                AutoNumber = 1
        Else
                Do
                    AutoNumber = AutoNumber + 1
                    rec.MoveFirst
                    Do While (rec.EOF = False)
                        TDM = DoEvents()
                        If Val(rec.Fields("UserID")) = AutoNumber Then
                                Valid = False
                                Exit Do
                        Else
                                Valid = True
                        End If
                        If rec.EOF = False Then rec.MoveNext
                    Loop
                Loop Until Valid = True
        End If                 '生成合法的AutoNumber后则继续往下走...
     
     '' Start check for username duplicate    开始检查用户名是否重复
                    rec.MoveFirst
                    Do While (rec.EOF = False)
                        TDM = DoEvents()
                        If rec.Fields("用户名") = Trim(txtUserName.Text) Then
                                MsgBox "这个名字已经占用！ " & vbCrLf & vbCrLf & "Change your 用户名. ", vbInformation, "Unable to add user"
                                db.Close
                                txtUserName.SetFocus
                                AddUserToDB = False
                                Exit Function
                        End If
                        If rec.EOF = False Then rec.MoveNext
                    Loop
                '' Start update new record fields   检查完毕后则开始更新动作
                 rec.AddNew
                 rec.Fields("UserID") = AutoNumber
                 rec.Fields("Date Entered") = Format(txtDateEntered.Text, "mm-dd-yyyy")
                 rec.Fields("用户名") = Trim(txtUserName.Text)
                 rec.Fields("密码") = Trim(txtPassword.Text)
                 rec.Fields("会员权限") = Trim(txtAccessLevel.Text)
                 rec.Fields("First Name") = Trim(txtFirstName.Text)
                 rec.Fields("Middle Name") = Trim(txtMiddleName.Text)
                 rec.Fields("姓氏") = Trim(txtFamilyName.Text)
                 rec.Fields("生日") = Trim(txtBirthday.Text)
                 rec.Fields("性别") = Trim(txtSex.Text)
                 rec.Fields("家庭住址") = Trim(txtHomeAddress.Text)
                 rec.Fields("联系号码") = Trim(txtContactNumber.Text)
                 rec.Fields("使用评价") = Trim(txtComments.Text)
                 rec.Update  ''Update the recordset
               '' End update new record fields
               db.Close  '' Close DB
               MsgBox "新用户记录成功添加！ ", vbInformation, "更新成功！"
               AddUserToDB = True      '用以标记是否往UserDB里添加过用户
End Function
Sub RemoveUser(UserID As Long)
On Error GoTo Err:
 Dim TDM As Variant
 Dim db As Database
 Dim rec As Recordset
 
 Set db = OpenDatabase(App.Path & "\Database\UsersDB.mdb", False, False, ";pwd=AdmiN")
 Set rec = db.OpenRecordset("Users", dbOpenTable)
 rec.MoveFirst
    Do While (rec.EOF = False)
       TDM = DoEvents()
       If Val(rec.Fields("UserID")) = UserID Then
           rec.Delete
           Exit Do
       End If
       If rec.EOF = False Then rec.MoveNext
    Loop
 MsgBox "已删除此系统用户！", vbInformation, "更新！"
 db.Close
Err:
End Sub
Sub LoadMembers(lst As ListBox, fw1 As String, fw2 As String) ''load UserNames in a listbox  往listbox里加载用户名
    On Error GoTo ErrorHandler:
    Dim db As Database
    Dim rec As Recordset
    Dim TDM As Variant
    Dim loop1, loop2 As Integer
    lst.Clear
    
    Set db = OpenDatabase(App.Path & "\Database\MembersDB.mdb", False, False, ";pwd=AdmiN")
    Set rec = db.OpenRecordset("MembersInfo", dbOpenTable)
      rec.MoveFirst
          rec.MoveFirst
    If rec.RecordCount > 0 And Val(fw2) >= Val(fw1) Then
     'loop1 = rec.RecordCount + 1
       For loop2 = Val(fw1) To Val(fw2)
        rec.MoveFirst
        For loop1 = 1 To rec.RecordCount
            TDM = DoEvents()
            If rec.Fields("ID NUMBER") <> loop2 Then
            rec.MoveNext
            Else: Exit For
            End If
        Next loop1
            lst.AddItem rec.Fields("ID NUMBER") & rec.Fields("姓氏") & ", " & rec.Fields("名字1") & Left(rec.Fields("名字2"), 1)
            rec.MoveNext
        Next loop2
     End If
  db.Close
  Exit Sub
ErrorHandler:
  db.Close
End Sub
Sub GetMemberInfo(lst As ListBox, txtDateEntered As TextBox, txtIDnumber As TextBox, txtNationality As TextBox, _
                  txtFirstName As TextBox, txtMiddleName As TextBox, txtFamilyName As TextBox, _