frmcdtapes.frm

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

  db.Close
  Exit Sub
ErrorHandler:
  db.Close
End Sub
Private Sub Optsstj_Click()
Call LoadssMoviesList(lstTitles)
End Sub
Sub LoadssMoviesList(lst As ListBox)
 Dim mySQL As String    '用以列出失损列表================================================
 Dim i As Integer
  Dim TDM As Variant
    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
        mySQL = "Select * FROM [CD Tapes Table] WHERE [剩余库存量] = 0"
        adoRecordset.Open mySQL, adoConnection, adOpenStatic, adLockOptimistic, adCmdText
        If adoRecordset.RecordCount <> 0 Then
        lst.Clear
         For i = 1 To adoRecordset.RecordCount
            TDM = DoEvents()
            'lst.AddItem rec.Fields("First Name") & " " & Left(rec.Fields("Middle Name"), 1) & ". " & _
            rec.Fields("Family Name")
            lst.AddItem adoRecordset.Fields("标题") & " [" & adoRecordset.Fields("Item Code") & "]"
            adoRecordset.MoveNext
         Next i
            MsgBox ("   共找到" & adoRecordset.RecordCount & "条记录")
            Else
            MsgBox ("没有相关记录集")
            Set adoRecordset = Nothing
            Set adoConnection = Nothing
            Exit Sub
        End If
End Sub
Private Sub cmdRemove_Click()
Dim vr_engine As VRENTAL_ENGINE
Set vr_engine = New VRENTAL_ENGINE
If lstTitles.Enabled = True And cmdUpdate.Enabled = False And cmdClear.Enabled = False And Trim(lstTitles.Text) <> "" Then
    If MsgBox("确定删除此文籍项目？", vbYesNo) = vbNo Then Exit Sub
    Call vr_engine.Remove_CD_tape_Items(txtItemCode.Text)
    Call cmdClear_Click
    txtDateEntered.Text = ""
    txtItemCode.Text = ""
    cmdEdit.Enabled = False
    Call vr_engine.LoadMoviesList(lstTitles, txtfw1, txtfw2) 'Refresh items list
    lstTitles.SetFocus
Else
    If lstTitles.Enabled = False Then
       txtTitle.SetFocus
    Else
       lstTitles.SetFocus
    End If
End If

End Sub
Private Sub cmdsxfw_Click()
Call Form_Load
End Sub

Private Sub cmdUpdate_Click()
  Dim vr_engine As VRENTAL_ENGINE
  Set vr_engine = New VRENTAL_ENGINE
 
       If cmdAddMovie.Caption = "&取消添加..." Then
         'Start - Validate input
         If ValidateTextBoxesEntries = True Then
            '' Do nothing
         Else
            Exit Sub
         End If
         'Update DB
         If vr_engine.Add_CD_TAPES_MovieToDB(txtTitle, txtDateEntered, txtItemCode, _
                    txtActor, txtYearReleased, txtGenre, txtRunTime, txtRentalAmount, _
                    txtAvailable, txtRentalPeriod, txtOverdueChargePerDay, txtLastDateBorrowed, txtLastDateBorrowedAddInfo, txtLastDateReturned, _
                    txtLastDateReturnedAddInfo, txtCondition, txtComments) = True Then
                    Call vr_engine.LoadMoviesList(lstTitles, txtfw1, txtfw2)
                    lstTitles.Text = Trim(txtTitle.Text) & " [" & Trim(txtItemCode.Text) & "]"
                    lstTitles.Enabled = True
                    lstTitles.SetFocus
                    cmdUpdate.Enabled = False
                    cmdClear.Enabled = False
                    cmdAddMovie.Caption = "添加"
                    Call LockTextboxes
         Else
             '' Do Nothing
         End If
         'End update
          Exit Sub
       End If
       
       If cmdEdit.Caption = "取消编辑" Then
         'Start - Validate input
         If ValidateTextBoxesEntries = True Then
            '' Do nothing
         Else
            Exit Sub
         End If
         'End - Validate input
            If vr_engine.UpdateEditedCDtapesInfo(tmpItemCodeB4Edit, txtTitle, txtDateEntered, txtItemCode, _
                        txtActor, txtYearReleased, txtGenre, txtRunTime, txtRentalAmount, _
                        txtAvailable, txtRentalPeriod, txtOverdueChargePerDay, txtLastDateBorrowed, txtLastDateBorrowedAddInfo, txtLastDateReturned, _
                        txtLastDateReturnedAddInfo, txtCondition, txtComments) = True Then
                    
                        Call vr_engine.LoadMoviesList(lstTitles, txtfw1, txtfw2)
                        lstTitles.Text = Trim(txtTitle.Text) & " [" & Trim(txtItemCode.Text) & "]"
                        lstTitles.Enabled = True
                         cmdAddMovie.Enabled = True
                        lstTitles.SetFocus
                        cmdUpdate.Enabled = False
                        cmdClear.Enabled = False
                        cmdEdit.Caption = "编辑"
                        Call LockTextboxes
            Else
            End If
       End If
End Sub
Private Sub Form_Load()
Dim vr_engine As VRENTAL_ENGINE
Set vr_engine = New VRENTAL_ENGINE
Call vr_engine.LoadMoviesList(lstTitles, txtfw1, txtfw2)
End Sub
Private Sub lstTitles_Click()
Dim vr_engine As VRENTAL_ENGINE
Set vr_engine = New VRENTAL_ENGINE

Call vr_engine.GetCD_TapesInfo(lstTitles, txtTitle, txtDateEntered, txtItemCode, _
                    txtActor, txtYearReleased, txtGenre, txtRunTime, txtRentalAmount, _
                    txtAvailable, txtRentalPeriod, txtOverdueChargePerDay, txtLastDateBorrowed, txtLastDateBorrowedAddInfo, txtLastDateReturned, _
                    txtLastDateReturnedAddInfo, txtCondition, txtComments)
                    
    lstTEXT = lstTitles.Text
    cmdEdit.Enabled = True
End Sub
Sub UnlockTextboxes()
            txtTitle.Locked = False
            txtItemCode.Locked = False
            txtActor.Locked = False
            txtYearReleased.Locked = False
            txtGenre.Locked = False
            txtRunTime.Locked = False
            txtRentalAmount.Locked = False
            txtAvailable.Locked = False
            txtOverdueChargePerDay.Locked = False
            txtRentalPeriod.Locked = False
            txtLastDateBorrowed.Locked = False
            txtLastDateBorrowedAddInfo.Locked = False
            txtLastDateReturned.Locked = False
            txtLastDateReturnedAddInfo.Locked = False
            txtCondition.Locked = False
            txtComments.Locked = False
End Sub
Sub LockTextboxes()
            txtTitle.Locked = True
            txtDateEntered.Locked = True
            txtItemCode.Locked = True
            txtActor.Locked = True
            txtYearReleased.Locked = True
            txtGenre.Locked = True
            txtRunTime.Locked = True
            txtRentalAmount.Locked = True
            txtAvailable.Locked = True
            txtOverdueChargePerDay.Locked = True
            txtRentalPeriod.Locked = True
            txtLastDateBorrowed.Locked = True
            txtLastDateBorrowedAddInfo.Locked = True
            txtLastDateReturned.Locked = True
            txtLastDateReturnedAddInfo.Locked = True
            txtCondition.Locked = True
            txtComments.Locked = True
End Sub
Function ValidateTextBoxesEntries() As Boolean
      '-----------------------------------------------------------------
          If Trim(txtTitle.Text) = "" Then
             MsgBox "必须输入标题！", vbInformation, "无法更新！"
             ValidateTextBoxesEntries = False
             txtTitle.SetFocus
             Exit Function
          End If
      '-----------------------------------------------------------------
          If Trim(txtItemCode.Text) = "" Then
             MsgBox "你必须输入文籍的项目编号. ", vbInformation, "不能更新！"
             ValidateTextBoxesEntries = False
             txtItemCode.SetFocus
             Exit Function
          End If
           'START - CHECKt Itemcode Format
      Dim str2 As String
      str2 = Trim(txtItemCode.Text)
      If Len(str2) <> 8 Then
         MsgBox "项目编号只能是 8 字节长 ", vbInformation, "非法编号！"
         txtItemCode.SetFocus
         Exit Function
      Else
         Dim t As String
         
         If UCase(Mid(str2, 1, 4)) <> UCase("CHN-") _
            And UCase(Mid(str2, 1, 4)) <> UCase("OTH-") _
              And UCase(Mid(str2, 1, 4)) <> UCase("ENG-") Then

               MsgBox "项目的前四个字节 " & vbCrLf & "必须为 'CHN-'(中文类), 'ENG-'(英语类), 或者 'OTH-'(杂类)三者之一。 ", vbInformation, "Invalid Item Code"
               txtItemCode.SetFocus
            Exit Function
         Else
                If IsNumeric(Mid(str2, 5, 1)) = False Then
                    MsgBox "编号的后四字节 " & vbCrLf & "必须为数字字符. ", vbInformation, "Invalid Item Code"
                    txtItemCode.SetFocus
                    Exit Function
                End If
                If IsNumeric(Mid(str2, 6, 1)) = False Then
                    MsgBox "编号的后四字节 " & vbCrLf & "必须为数字字符. ", vbInformation, "Invalid Item Code"
                    txtItemCode.SetFocus
                    Exit Function
                End If
                If IsNumeric(Mid(str2, 7, 1)) = False Then
                    MsgBox "编号的后四字节 " & vbCrLf & "必须为数字字符. ", vbInformation, "Invalid Item Code"
                    txtItemCode.SetFocus
                    Exit Function
                End If
                If IsNumeric(Mid(str2, 8, 1)) = False Then
                    MsgBox "编号的后四字节 " & vbCrLf & "必须为数字字符. ", vbInformation, "Invalid Item Code"
                    txtItemCode.SetFocus
                Exit Function
            End If
         End If
      End If
     txtItemCode.Text = UCase(txtItemCode.Text)
       '-----------------------------------------------------------------
          If Trim(txtActor.Text) = "" Then
             MsgBox "你必须输入文籍的作者. ", vbInformation, "Cannot update"
             ValidateTextBoxesEntries = False
             txtActor.SetFocus
             Exit Function
          End If
       '-----------------------------------------------------------------
          If Trim(txtYearReleased.Text) = "" Then
             If MsgBox("""出版年份"" 为空！  " & vbCrLf & vbCrLf & "你想继续输入吗?", vbYesNo, "Update Info") = vbNo Then
                ValidateTextBoxesEntries = False
                txtYearReleased.SetFocus
                Exit Function
             End If
          End If
       '-----------------------------------------------------------------
          If Trim(txtGenre.Text) = "" Then
             If MsgBox("""关键字"" 为空！  " & vbCrLf & vbCrLf & "你想继续输入吗?", vbYesNo, "Update Info") = vbNo Then
                ValidateTextBoxesEntries = False
                txtGenre.SetFocus
                Exit Function
             End If
          End If
      '-----------------------------------------------------------------
          If Trim(txtRunTime.Text) = "" Then
             If MsgBox("""页数"" 为空！  " & vbCrLf & vbCrLf & "你想继续输入吗?", vbYesNo, "Update Info") = vbNo Then
                ValidateTextBoxesEntries = False
                txtRunTime.SetFocus
                Exit Function
             End If
          End If
      '-----------------------------------------------------------------
          If Trim(txtRentalAmount) = "" Then
             MsgBox """租金"" 未填！ ", vbInformation, "Cannot update"
             txtRentalAmount.SetFocus
             ValidateTextBoxesEntries = False
             Exit Function
          Else
             If IsNumeric(Trim(txtRentalAmount.Text)) Then
             '' do nothing
             Else
             MsgBox """Rental Amount"" is invalid. ", vbInformation, "无法更新"
             txtRentalAmount.SetFocus
             ValidateTextBoxesEntries = False
             Exit Function
             End If
          End If
      '-----------------------------------------------------------------
          If Trim(txtAvailable.Text) = "此项目已失损" Then
          MsgBox "注意，这是个失损的项目！"
          Else:
          If Trim(txtAvailable.Text) = "" Then
             MsgBox """是否可租"" 项是空的！ " & vbCrLf & vbCrLf & "请输入'Yes' or 'No'    ", vbInformation, "Cannot update"
             txtAvailable.SetFocus
             ValidateTextBoxesEntries = False
             Exit Function
          Else
             If UCase(Trim(txtAvailable.Text)) = "YES" Or UCase(Trim(txtAvailable.Text)) = "NO" Then
                    If Left(UCase(Trim(txtAvailable.Text)), 1) = "Y" Then txtAvailable.Text = "Yes"
                    If Left(UCase(Trim(txtAvailable.Text)), 1) = "N" Then txtAvailable.Text = "No"
             Else
                        MsgBox """是否可租"" 输入非法！   " & vbCrLf & vbCrLf & "Please enter 'Yes' or 'No'    ", vbInformation, "Cannot update"
                        txtAvailable.SetFocus
                        ValidateTextBoxesEntries = False
                        Exit Function
             End If
          End If
          End If
      ' ----------------------------------------------------------------
        If IsNumeric(Trim(txtRentalPeriod.Text)) = True Then
            If Int(Val(Trim(txtRentalPeriod.Text))) <= 0 Then
                MsgBox "租期为空或非法输入！", vbInformation, "Input Error: "
                ValidateTextBoxesEntries = False
                txtRentalPeriod.SetFocus
                Exit Function
            End If
            txtRentalPeriod.Text = Trim(str(Int(Trim(txtRentalPeriod.Text))))
        Else
                MsgBox "租期为空或非法输入！", vbInformation, "Input Error: "
                ValidateTextBoxesEntries = False
                txtRentalPeriod.SetFocus
                Exit Function
             
        End If
      ' ----------------------------------------------------------------
        'txtOverdueChargePerDay
        If IsNumeric(Trim(txtOverdueChargePerDay.Text)) = True Then
            If Int(Val(Trim(txtOverdueChargePerDay.Text))) < 0 Then
                MsgBox "过期缴纳项目为空或非法 ", vbInformation, "Input Error: "
                ValidateTextBoxesEntries = False
                txtOverdueChargePerDay.SetFocus
                Exit Function
            End If
          txtOverdueChargePerDay.Text = Trim(txtOverdueChargePerDay.Text)
        Else
                MsgBox "过期缴纳项目为空或非法 ", vbInformation, "Input Error: "
                ValidateTextBoxesEntries = False
                txtOverdueChargePerDay.SetFocus
                Exit Function
        End If
      '-----------------------------------------------------------------
          If IsDate(Trim(txtLastDateBorrowed.Text)) Then
             txtLastDateBorrowed.Text = Format(Trim(txtLastDateBorrowed.Text), "mmm. dd, yyyy")
          Else
             If Trim(txtLastDateBorrowed.Text) <> "" Then
                MsgBox """Last Date Borrowed"" 输入非法！ ", vbInformation, "无法更新"
                txtLastDateBorrowed.SetFocus
                ValidateTextBoxesEntries = False
                Exit Function
             End If
          End If
      '-----------------------------------------------------------------
            If IsDate(Trim(txtLastDateReturned.Text)) Then
                 txtLastDateReturned.Text = Format(Trim(txtLastDateReturned.Text), "mmm. dd, yyyy")
            Else
                 If Trim(txtLastDateReturned.Text) <> "" Then
                    MsgBox """Last Date Returned"" 输入非法！ ", vbInformation, "Cannot update"
                    txtLastDateReturned.SetFocus
                    ValidateTextBoxesEntries = False
                    Exit Function
                End If
            End If
      
      '-----------------------------------------------------------------
            If Trim(txtCondition.Text) = "" Then
               MsgBox "请输入读者评价！. " & vbCrLf & vbCrLf & "格式为: 好，一般或者差，三者之其一", vbInformation, "不能更新数据"
               txtCondition.SetFocus
               ValidateTextBoxesEntries = False
               Exit Function
            Else
               If Trim(txtCondition.Text) = "好" Or Trim(txtCondition.Text) = "一般" Or Trim(txtCondition.Text) = "差" Or _
                  Trim(txtCondition.Text) = "很好" Or Trim(txtCondition.Text) = "一般般" Or Trim(txtCondition.Text) = "很差" Or Trim(txtCondition.Text) = "非常差" Or _
                  Trim(txtCondition.Text) = "非常好" Then
                   If Trim(txtCondition.Text) = "很好" Then txtCondition.Text = "好"
                   If Trim(txtCondition.Text) = "非常好" Then txtCondition.Text = "好"
                   If Trim(txtCondition.Text) = "一般般" Then txtCondition.Text = "一般"
                   If Trim(txtCondition.Text) = "很差" Then txtCondition.Text = "差"
                   If Trim(txtCondition.Text) = "非常差" Then txtCondition.Text = "差"
               Else
                    MsgBox "非法评价！ " & vbCrLf & vbCrLf & "格式必须为: 好，一般或者差，三者之其一", vbInformation, "不能更新数据"
                    txtCondition.SetFocus
                    ValidateTextBoxesEntries = False
                    Exit Function
               End If
            End If
          ValidateTextBoxesEntries = True
End Function
Private Sub txtAvailable_LostFocus()
If UCase(txtAvailable.Text) = "Y" Then txtAvailable.Text = "Yes"
If UCase(txtAvailable.Text) = "N" Then txtAvailable.Text = "No"
End Sub

Private Sub txtItemCode_LostFocus()
 Dim str As String
 Dim loop1 As Integer
 If Trim(txtItemCode.Text) <> "" Then
    For loop1 = 1 To Len(txtItemCode.Text)
       If Mid(Trim(txtItemCode.Text), loop1, 1) = " " Then
          MsgBox "项目编号不能包含空字符！ ", vbInformation, "Invalid Entry"
          txtItemCode.Text = ""
          txtItemCode.SetFocus
       End If
    Next
 End If
End Sub
Private Sub txtRentalAmount_LostFocus()
  If IsNumeric(txtRentalAmount) = True Then txtRentalAmount.Text = Format(txtRentalAmount.Text, "##,##0.00")
End Sub