vrental_engine.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "VRENTAL_ENGINE"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Dim loop4 As Long   '用于Report_LoadUnreturnedItems过程
Dim counterdq As Long ' 用于LoadItemsToBeReturnedTod
'Option Base 1
Function CheckPermission(Level As Integer, Fcode As Integer) As Boolean
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 Level
    str = Trim(rec.Fields("Permissions"))
    For loop2 = 1 To 7
        If loop2 = Fcode And loop1 = Level Then
           If Int(Val(Mid(str, loop2, 1))) = 1 Then
              CheckPermission = True
              Exit Function
           Else
              MsgBox "你没有权限使用此项功能！ ", vbInformation, "权限拒绝"
              CheckPermission = False
              Exit Function
           End If
        End If
        counter = counter + 1
    Next loop2
    If rec.EOF = False Then rec.MoveNext
Next loop1

Set db = Nothing
Set rec = Nothing
End Function
Function Date_GETDATE(NumberOfDaysFromJanYear1 As Long) As String
    Dim YearCount As Integer
    Dim Days, i, iMonth(12) As Integer
    Dim GET_Day As Long
    Dim strDay As String
    'Get Day  取得星期
     GET_Day = NumberOfDaysFromJanYear1 Mod 7
     
   Select Case GET_Day
    Case 1: strDay = "Sunday"
    Case 2: strDay = "Monday"
    Case 3: strDay = "Tuesday"
    Case 4: strDay = "Wednesday"
    Case 5: strDay = "Thursday"
    Case 6: strDay = "Friday"
    Case 0: strDay = "Saturday"
   End Select
    
    iMonth(1) = 31 'Jan
    iMonth(2) = 28 'Feb
    iMonth(3) = 31 'Mar
    iMonth(4) = 30 'Apr
    iMonth(5) = 31 'May
    iMonth(6) = 30 'Jun
    iMonth(7) = 31 'Jul
    iMonth(8) = 31 'Aug
    iMonth(9) = 30 'Sep
    iMonth(10) = 31 'Oct
    iMonth(11) = 30 'Nov
    iMonth(12) = 31 'Dec
    
    'Get Year 取得月份
    YearCount = 1
    Days = 365
    Do While NumberOfDaysFromJanYear1 > Days
       NumberOfDaysFromJanYear1 = NumberOfDaysFromJanYear1 - Days
       If NumberOfDaysFromJanYear1 > 0 Then YearCount = YearCount + 1
       If YearCount Mod 4 = 0 Then
          Days = 366
       Else
          Days = 365
       End If
    Loop
    
    'Get Month and Day  取得月份和日期
    If YearCount Mod 4 = 0 Then iMonth(2) = 29
    If NumberOfDaysFromJanYear1 <> 0 Then
      i = 1
      Do While NumberOfDaysFromJanYear1 > iMonth(i)
         NumberOfDaysFromJanYear1 = NumberOfDaysFromJanYear1 - iMonth(i)
         i = i + 1
      Loop
    Else
      i = 12
      NumberOfDaysFromJanYear1 = 31
    End If
    
   Date_GETDATE = str(i) & "/" & Trim(str(NumberOfDaysFromJanYear1)) & "/" & Trim(str(YearCount))
    
End Function
Function Date_CountNumberOfDaysFromJan1Year1ToDec31YearEntered(YearEntered As Long) As Long
    Dim TotalDays, Year As Long
    Dim Days, DaysInAYear, counter As Integer

    TotalDays = 730500 ' No. Of days from 1/1/1 to 12/31/2000
    counter = 1
    DaysInAYear = 365
'730499
    For Year = 2001 To YearEntered
        For Days = 1 To DaysInAYear
            TotalDays = TotalDays + 1
        Next Days
        counter = counter + 1
        If counter = 4 Then  ' Leap Year
            counter = 0
            DaysInAYear = 366
        Else
            DaysInAYear = 365
        End If
    Next Year

    Date_CountNumberOfDaysFromJan1Year1ToDec31YearEntered = TotalDays

End Function
Function Date_CountDaysInAYear(DateEntered As String) As Integer
Dim DateDay, DateMonth, DateYear, iMonth(12), _
    loop1, TotalDays As Integer

iMonth(1) = 31 'Jan
iMonth(2) = 28 'Feb
iMonth(3) = 31 'Mar
iMonth(4) = 30 'Apr
iMonth(5) = 31 'May
iMonth(6) = 30 'Jun
iMonth(7) = 31 'Jul
iMonth(8) = 31 'Aug
iMonth(9) = 30 'Sep
iMonth(10) = 31 'Oct
iMonth(11) = 30 'Nov
iMonth(12) = 31 'Dec

   DateYear = Year(DateEntered)
   DateMonth = Month(DateEntered)
   DateDay = Day(DateEntered)
'Check if year is leapyear
If DateYear Mod 4 = 0 Then iMonth(2) = 29
TotalDays = 0
For loop1 = 1 To DateMonth
   If loop1 = DateMonth Then TotalDays = TotalDays + DateDay
   If loop1 < DateMonth Then TotalDays = TotalDays + iMonth(loop1)
Next loop1

Date_CountDaysInAYear = TotalDays

End Function
Sub CopyFlexDataToExcel(Flex As MSFlexGrid)
On Error GoTo ErrHandler
Dim EXCELApp As Excel.Application
Dim EXCELWorkBook As Excel.Workbook
Dim Rows, Cols As Integer
Dim iRow, hCol, iCol As Integer
Dim New_Col As Boolean

    If Flex.Rows <= 1 Then
        MsgBox "没有记录以供导出！", vbInformation, App.Title
        Exit Sub
    End If
    
    Set EXCELApp = CreateObject("Excel.application")
    Set EXCELWorkBook = EXCELApp.Workbooks.Add
    
    Dim New_Column As Boolean
    With Flex
        Rows = .Rows
        Cols = .Cols
        iRow = 0
        iCol = 1
        For hCol = 0 To Cols - 1
            For iRow = 1 To Rows
                EXCELApp.Cells(iRow + 1, iCol + 1).Value = .TextMatrix(iRow - 1, hCol)
            Next iRow
            iCol = iCol + 1
        Next hCol
    End With
    
    EXCELApp.Rows(2).Font.Bold = True
    EXCELApp.Cells.Select
    EXCELApp.Columns.AutoFit
    EXCELApp.Cells(1, 1).Select
    EXCELApp.Application.Visible = True
    
    Set EXCELWorkBook = Nothing
    Set EXCELApp = Nothing
    Flex.SetFocus
    MsgBox "成功导出内容到Excel ", vbInformation, "成功导出！"
Exit Sub
ErrHandler:
  MsgBox "无法打开Excel！ ", vbInformation, "提示 "
End Sub
Public Function ReplaceString(ByVal TextString As String, ByVal FromString As String, ByVal ToString As String)
Dim new_TextString As String
Dim Position As Integer

    Do While Len(TextString) > 0
        Position = InStr(TextString, FromString)
        If Position = 0 Then
            new_TextString = new_TextString & TextString
            TextString = ""
        Else
            new_TextString = new_TextString & Left$(TextString, Position - 1) & ToString
            TextString = Mid$(TextString, Position + Len(FromString))
        End If
    Loop

    ReplaceString = new_TextString
End Function
Function LogOnValidate(UserName As String, password As String) As String
    Dim db As Database
    Dim rec As Recordset
    Dim TDM As Variant
    Dim loop1 As Integer

    LogOnValidate = 0
    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()
            If rec.Fields("用户名") = UserName And _
                rec.Fields("密码") = password Then
                LogOnValidate = "User ID : " & rec.Fields("UserID") & vbCrLf _
                                & "Date Entered : " & rec.Fields("Date Entered") & vbCrLf _
                                & "用户名 : " & rec.Fields("用户名") & vbCrLf _
                                & "密码 : " & rec.Fields("密码") & vbCrLf _
                                & "Access Level : " & rec.Fields("会员权限") & vbCrLf _
                                & "First Name : " & rec.Fields("First Name") & vbCrLf _
                                & "Middle Name : " & rec.Fields("Middle Name") & vbCrLf _
                                & "姓氏: " & rec.Fields("姓氏") & vbCrLf _
                                & "生日: " & rec.Fields("生日") & vbCrLf & "Age : " & str(GetAge(rec.Fields("生日"))) & vbCrLf _
                                & "性别 : " & rec.Fields("性别") & vbCrLf _
                                & "家庭住址 : " & rec.Fields("家庭住址") & vbCrLf _
                                & "联系号码 : " & rec.Fields("联系号码") & vbCrLf _
                                & "Comments : " & rec.Fields("使用评价") & vbCrLf
                Exit For
            Else
                LogOnValidate = ""
            End If
            rec.MoveNext  ' Move to the next record
        Next loop1
    End If
    db.Close
End Function
Public Sub ChangePassword(NewPWD As String, UserName As String)
     
    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)
    
    rec.MoveFirst
    If rec.RecordCount > 0 Then
        For loop1 = 1 To rec.RecordCount
            TDM = DoEvents()
            If rec.Fields("用户名") = UserName Then
                '' Start Change 密码
                rec.Edit
                rec.Fields("密码") = NewPWD
                rec.Update
                '' End Change 密码
            End If
        
            rec.MoveNext  ' Move to the next record
        Next loop1
     End If
      db.Close
End Sub
Function GetAge(myDate As Variant) As Integer
 Dim numyears, numMonths
 myDate = CDate(myDate)
 Dim TotalDays As Long
 TotalDays = DateDiff("y", myDate, Date)
 numyears = Abs(TotalDays / 365.25)