vrental_engine.cls

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

    Dim loop1 As Integer
    
    Set db = OpenDatabase(App.Path & "\Database\CD_Tapes.mdb", False, False, ";pwd=AdmiN")
    Set rec = db.OpenRecordset("CD Tapes Table", dbOpenTable)
    
    If rec.BOF = True And rec.EOF = True Then
     ' Do Nothing
    Else
        'chk for item code duplicates  检查条目密码是否重复
            rec.MoveFirst
            For loop1 = 1 To rec.RecordCount
                TDM = DoEvents()
                If Trim(txtItemCode.Text) = rec.Fields("Item Code") Then
                    MsgBox "项目编号已被占用！ ", vbInformation, "Adding ERROR!"
                    db.Close
                    Add_CD_TAPES_MovieToDB = False
                    Exit Function
                End If
                If rec.EOF = False Then rec.MoveNext
            Next loop1
        
    End If
 '-------- START ADDING ----------
                    rec.AddNew
                    rec.Fields("标题") = Trim(txtTitle.Text)
                    rec.Fields("入库时间") = Trim(txtDateEntered.Text)
                    rec.Fields("Item Code") = Trim(txtItemCode.Text)
                    rec.Fields("作者") = Trim(txtAuthor.Text)
                    rec.Fields("出版年份") = Trim(txtYearReleased.Text)
                    rec.Fields("关键字") = Trim(txtGenre.Text)
                    rec.Fields("页数") = Trim(txtRunTime.Text)
                    rec.Fields("Rental Amount") = Trim(txtRentalAmount.Text)
                    rec.Fields("是否可租") = Trim(txtAvailable.Text)
                    rec.Fields("RentalPeriod") = Trim(txtRentalPeriod.Text)
                    rec.Fields("OverdueChargePerDay") = Trim(txtOverdueChargePerDay.Text)
                    If IsDate(Trim(txtLastDateBorrowed.Text)) = True Then rec.Fields("租借日期") = Trim(txtLastDateBorrowed.Text)
                    rec.Fields("LastDateBorrowedAddInfo") = Trim(txtLastDateBorrowedAddInfo.Text)
                    If IsDate(Trim(txtLastDateReturned.Text)) = True Then rec.Fields("LastDateReturned") = Trim(txtLastDateReturned.Text)
                    rec.Fields("LastDateReturnedAddInfo") = Trim(txtLastDateReturnedAddInfo.Text)
                    rec.Fields("Condition") = Trim(txtCondition.Text)
                    rec.Fields("剩余库存量") = Trim(txtComments.Text)
                    rec.Update
 '-------- END ADDING ------------
     
   db.Close
   MsgBox "新项目已添加！", vbInformation, "添加成功！"
   Add_CD_TAPES_MovieToDB = True

End Function
Function UpdateEditedCDtapesInfo(tmpItemCodeB4Edit As String, txtTitle As TextBox, txtDateEntered As TextBox, txtItemCode As TextBox, _
                    txtAuthor As TextBox, txtYearReleased As TextBox, txtGenre As TextBox, txtRunTime As TextBox, txtRentalAmount As TextBox, _
                    txtAvailable As TextBox, txtRentalPeriod As TextBox, txtOverdueChargePerDay As TextBox, txtLastDateBorrowed As TextBox, txtLastDateBorrowedAddInfo As TextBox, txtLastDateReturned As TextBox, _
                    txtLastDateReturnedAddInfo As TextBox, txtCondition As TextBox, txtComments As TextBox) As Boolean
 Dim db As Database
    Dim rec As Recordset
    Dim TDM As Variant
    Dim loop1 As Integer
    
    Set db = OpenDatabase(App.Path & "\Database\CD_Tapes.mdb", False, False, ";pwd=AdmiN")
    Set rec = db.OpenRecordset("CD Tapes Table", dbOpenTable)
    ' Start for ItemCode duplicates
      If tmpItemCodeB4Edit <> Trim(txtItemCode.Text) Then
             
            rec.MoveFirst
            For loop1 = 1 To rec.RecordCount
                TDM = DoEvents()
                If Trim(txtItemCode.Text) = rec.Fields("Item Code") Then
                    MsgBox "注意，此编号已经占用。", vbInformation, "更新错误！"
                    db.Close
                     UpdateEditedCDtapesInfo = False
                    Exit Function
                End If
                If rec.EOF = False Then rec.MoveNext
            Next loop1
      End If
    ' End check 4 Item code duplicates
    ' Start - Look 4 record 在没有发现占用情况后开始定位要求修改的记录
      rec.MoveFirst
      For loop1 = 1 To rec.RecordCount
                TDM = DoEvents()
                If tmpItemCodeB4Edit = rec.Fields("Item Code") Then
                    Exit For
                End If
                If rec.EOF = False Then rec.MoveNext
      Next loop1
 '-------- START Update Edit ----------
                    rec.Edit
                    rec.Fields("标题") = Trim(txtTitle.Text)
                    rec.Fields("入库时间") = Trim(txtDateEntered.Text)
                    rec.Fields("Item Code") = Trim(txtItemCode.Text)
                    rec.Fields("作者") = Trim(txtAuthor.Text)
                    rec.Fields("出版年份") = Trim(txtYearReleased.Text)
                    rec.Fields("关键字") = Trim(txtGenre.Text)
                    rec.Fields("页数") = Trim(txtRunTime.Text)
                    rec.Fields("Rental Amount") = Trim(txtRentalAmount.Text)
                    rec.Fields("是否可租") = Trim(txtAvailable.Text)
                    rec.Fields("RentalPeriod") = Trim(txtRentalPeriod.Text)
                    rec.Fields("OverdueChargePerDay") = Trim(txtOverdueChargePerDay.Text)
                    If IsDate(Trim(txtLastDateBorrowed.Text)) = False Then
                         rec.Fields("租借日期") = Null
                    Else
                         rec.Fields("租借日期") = Trim(txtLastDateBorrowed.Text)
                    End If
                    rec.Fields("LastDateBorrowedAddInfo") = Trim(txtLastDateBorrowedAddInfo.Text)
                    If IsDate(Trim(txtLastDateReturned.Text)) = False Then
                       rec.Fields("租借日期") = Null
                    Else
                       rec.Fields("租借日期") = Trim(txtLastDateReturned.Text)
                    End If
                    rec.Fields("LastDateReturnedAddInfo") = Trim(txtLastDateReturnedAddInfo.Text)
                    rec.Fields("Condition") = Trim(txtCondition.Text)
                    rec.Fields("剩余库存量") = Trim(txtComments.Text)
                    rec.Update
 '-------- END Update Edit ------------
   db.Close
   MsgBox "记录已经添加。 ", vbInformation, "数据更新完毕"
  UpdateEditedCDtapesInfo = True
End Function
Sub bbssUpdateCDtapesInfo(bjssItemCode As String)
 Dim db As Database
    Dim rec As Recordset
    Dim TDM As Variant
    Dim loop1 As Integer
    
    Set db = OpenDatabase(App.Path & "\Database\CD_Tapes.mdb", False, False, ";pwd=AdmiN")
    Set rec = db.OpenRecordset("CD Tapes Table", dbOpenTable)
    ' Start - Look 4 record
      rec.MoveFirst
      For loop1 = 1 To rec.RecordCount
                TDM = DoEvents()
                If bjssItemCode = rec.Fields("Item Code") Then
                 If MsgBox("确定要标记为失损吗？", vbYesNo, "注意！") = vbYes Then
                 GoTo 1
                    'Exit For
                 Else: Exit Sub
                End If
                End If
                If rec.EOF = False Then rec.MoveNext
      Next loop1
 '-------- START Update Edit ----------
1:                  rec.Edit
                    rec.Fields("是否可租") = "此项目已失损"
                    'rec.Fields("LastDateReturnedAddInfo") = Trim(txtLastDateReturnedAddInfo.Text)
                    rec.Update
 '-------- END Update Edit ------------
   db.Close
   MsgBox bjssItemCode & " 项目记录已成功标记为失损。 ", vbInformation, "数据更新完毕"
  'UpdateEditedCDtapesInfo = True
End Sub
Sub Remove_CD_tape_Items(ItemCode As String)
 Dim db As Database
    Dim rec As Recordset
    Dim TDM As Variant
    Dim loop1 As Integer
    Set db = OpenDatabase(App.Path & "\Database\CD_Tapes.mdb", False, False, ";pwd=AdmiN")
    Set rec = db.OpenRecordset("CD Tapes Table", dbOpenTable)
            rec.MoveFirst
            For loop1 = 1 To rec.RecordCount
                TDM = DoEvents()
                If ItemCode = rec.Fields("Item Code") Then
                    rec.Delete
                    db.Close
                    Exit For
                End If
                If rec.EOF = False Then rec.MoveNext
            Next loop1
      MsgBox "记录已被成功删除！", vbInformation, "Record removed"
End Sub
Sub Search_Movies(FlexMovies As MSFlexGrid, SearchString As String, SearchFields As String, SearchMode As Boolean, SortByFields As String, SortMode As Boolean)
    Dim TDM As Variant
    Dim loop1, loop2 As Long
    Dim mySQL As String
    Dim adoConnection As ADODB.Connection
    Dim adoRecordset As ADODB.Recordset
    Dim connectString As String

    Set adoConnection = New ADODB.Connection
    Set adoRecordset = New ADODB.Recordset
    connectString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\DataBase\CD_Tapes.mdb;Persist Security Info=False;Jet OLEDB:Database Password=AdmiN"
    adoConnection.Open connectString
   
With FlexMovies
    .ColWidth(0) = 600
    .ColWidth(1) = 1000
    .ColWidth(2) = 1000
    .ColWidth(3) = 3000
    .ColWidth(4) = 1500
    .ColWidth(5) = 1650
    .ColWidth(6) = 920
    .ColWidth(7) = 900
    .ColWidth(8) = 800
    .ColAlignment(0) = 5
    .ColAlignment(1) = 5
    .ColAlignment(2) = 5
    .ColAlignment(3) = 2
    .ColAlignment(4) = 2
    .ColAlignment(5) = 5
    .ColAlignment(6) = 5
    .ColAlignment(7) = 5
    .ColAlignment(8) = 5
    
    .TextMatrix(0, 0) = "No."
    .TextMatrix(0, 1) = "项目编号"
    .TextMatrix(0, 2) = "入库时间"
    .TextMatrix(0, 3) = "标题"
    .TextMatrix(0, 4) = "作者"
    .TextMatrix(0, 5) = "关键字"
    .TextMatrix(0, 6) = "出版年份"
    .TextMatrix(0, 7) = "是否可租"
    .TextMatrix(0, 8) = "剩余量"
End With
'' ---------Start SQL
  If SearchString = "[所有文籍]" Or SearchString = "*" Or SearchString = "" Then
     mySQL = "SELECT * from [CD Tapes Table] ORDER by [" & SortByFields & "]"
  Else
     If SearchMode = True Then
        mySQL = "SELECT * from [CD Tapes Table] WHERE [" & SearchFields & "] LIKE '%" & SearchString & "%' ORDER by [" & SortByFields & "]"
     Else
        mySQL = "SELECT * from [CD Tapes Table] WHERE [" & SearchFields & "] = " & """" & SearchString & """" & "ORDER by [" & SortByFields & "]"
     End If
  End If
adoRecordset.Open mySQL, adoConnection, adOpenStatic, adLockOptimistic, adCmdText
'' --------End SQL

If adoRecordset.BOF = True And adoRecordset.EOF = True Then
           MsgBox "没有匹配记录 ", vbInformation, "无此信息"
           Exit Sub
End If
Select Case SortMode
Case True:
  '---------- Forward Processing -------------------升序排列
        FlexMovies.Rows = 1
        loop1 = 0
        
        adoRecordset.MoveFirst
        Do Until adoRecordset.EOF
             TDM = DoEvents()
             loop1 = loop1 + 1
             FlexMovies.AddItem ""
                For loop2 = 0 To 8
                    Select Case loop2
                        Case 0:
                                FlexMovies.TextMatrix(loop1, loop2) = str(loop1)
                        Case 1:
                                FlexMovies.TextMatrix(loop1, loop2) = adoRecordset![Item Code]
                        Case 2:
                                FlexMovies.TextMatrix(loop1, loop2) = adoRecordset![入库时间]
                        Case 3:
                                FlexMovies.TextMatrix(loop1, loop2) = adoRecordset![标题]
                        Case 4:
                                FlexMovies.TextMatrix(loop1, loop2) = adoRecordset![作者]
                        Case 5:
                                FlexMovies.TextMatrix(loop1, loop2) = adoRecordset![关键字]
                        Case 6:
                                FlexMovies.TextMatrix(loop1, loop2) = adoRecordset![出版年份]
                        Case 7:
                                FlexMovies.TextMatrix(loop1, loop2) = adoRecordset![是否可租]
                        Case 8:
                                FlexMovies.TextMatrix(loop1, loop2) = adoRecordset![剩余库存量]
                    End Select
                Next loop2
            adoRecordset.MoveNext
         Loop
         'FlexMovies.Rows = FlexMovies.Rows - 1
  '-----------------------------------------------
Case False:
'---START--- Backward Proceesing (Sort) 降序排列
Dim tmpArray() As Variant
Dim counter, countdown As Long
counter = 0
loop1 = 0
        adoRecordset.MoveFirst
        FlexMovies.Rows = 1
        Do Until adoRecordset.EOF
             TDM = DoEvents()
             loop1 = loop1 + 1
             counter = counter + 9
             ReDim Preserve tmpArray(counter)
             'FlexMovies.AddItem ""
                For loop2 = 0 To 8
                    Select Case loop2
                        Case 0:
                                tmpArray(counter - 8 + loop2) = str(loop1)
                        Case 1:
                                tmpArray(counter - 8 + loop2) = adoRecordset![Item Code]
                        Case 2:
                                tmpArray(counter - 8 + loop2) = adoRecordset![入库时间]
                        Case 3:
                                tmpArray(counter - 8 + loop2) = adoRecordset![标题]
                        Case 4:
                                tmpArray(counter - 8 + loop2) = adoRecordset!作者
                        Case 5:
                                tmpArray(counter - 8 + loop2) = adoRecordset!关键字
                        Case 6: