frmborrowreturn.frm

本人用VB 6.0和ACCESS编写的图书管理系统

    End If
    If dtmBorrowDate = dtmReturnDate Then
        MsgBox "当天借书不能当天还！", vbExclamation + vbOKOnly
        rs4.Close
        db3.Close
        Set rs4 = Nothing
        Set db3 = Nothing
        Exit Sub
    End If
    rs4.Close
    db3.Close
    Set rs4 = Nothing
    Set db3 = Nothing
        
    strAppName = App.Path & "\图书库.mdb"                   '打开图书库
    Set db = ws.OpenDatabase(strAppName, True, False)           '以独占、可写方式打开数据库
    strSQL = "select 图书编号,图书名称,图书总数,现存数量,图书价格,借出标志,遗失标志 from 图书表 where 图书编号='" & strBookNo & "'"
    Set rs = db.OpenRecordset(strSQL)
    Dim intNowCount, intBookCount As Integer, sngBookPrice As Single, blnBorrowFlag, blnLostFlag As Boolean
    intBookCount = rs.Fields("图书总数")
    intNowCount = rs.Fields("现存数量")
    sngBookPrice = rs.Fields("图书价格")
    blnBorrowFlag = rs.Fields("借出标志")
    blnLostFlag = rs.Fields("遗失标志")
    
    strAppName = App.Path & "\借书证库.mdb"                 '打开借书证库
    Set db1 = ws.OpenDatabase(strAppName, True, False)       '以独占、可写方式打开数据库
    Dim strCardStyle As String
    strCardStyle = Mid(strCardNo, 1, 1)
    strSQL = "select 借书证号,登记日期,押金,借阅数量,作废标志 from 借书证表 where 借书证号='" & strCardNo & "'"
    Set rs1 = db1.OpenRecordset(strSQL)
    Dim intBorrowCount As Integer, dtmRegisterDate As Date, blnCancelFlag As Boolean
    intBorrowCount = rs1.Fields("借阅数量")
    dtmRegisterDate = rs1.Fields("登记日期")
    blnCancelFlag = rs1.Fields("作废标志")
    strSQL = "select 有效日期,可借书本数,借书天数,费用,押金,会员标志 from 借书证类型表 where 借书证类型='" & strCardStyle & "'"
    Set rs2 = db1.OpenRecordset(strSQL)
    Dim intBorrowBookCount As Integer, sngAvailable
    Dim dtmValidate, dtmNow As Date
    intBorrowBookCount = rs2.Fields("可借书本数")
    sngAvailable = rs2.Fields("有效日期")
    If sngAvailable <> Int(sngAvailable) Then
        dtmValidate = DateAdd("d", sngAvailable * 365, dtmRegisterDate)
    Else
        dtmValidate = DateAdd("yyyy", sngAvailable, dtmRegisterDate)
    End If
    dtmNow = FormatDateTime(Now, vbShortDate)
    
    '如果借阅数量大于0,且借书证有效日期大于当前日期,则还书(没有作废的借书证),若遗失完,则该图书作废
    If Not blnCancelFlag And intBorrowCount > 0 And Not (blnLostFlag And intBookCount = 0) Then
        If chkLost Then             '遗失
            intBookCount = intBookCount - 1
        Else
            intNowCount = intNowCount + 1
        End If
        If intNowCount = intBookCount Then blnBorrowFlag = False
        rs.Edit
        rs.Fields("现存数量") = intNowCount
        rs.Fields("图书总数") = intBookCount
        rs.Fields("借出标志") = blnBorrowFlag
        rs.Fields("遗失标志") = chkLost
        rs.Update
        
        intBorrowCount = intBorrowCount - 1                 '借阅数量-1
        rs1.Edit
        rs1.Fields("借阅数量") = intBorrowCount
        rs1.Update
        txtBorrowCount(1).Text = intBorrowCount
        
        '向读者借书库中修改记录
        strAppName = App.Path & "\读者借书库.mdb"
        Set db3 = ws.OpenDatabase(strAppName, True, False)          '以独占、可写方式打开数据库
        strSQL = "select * from 读者借书表 where 借书证号='" & strCardNo & "' and 所借图书编号='" & strBookNo & "'" _
                & " and 还书标志=false"
        Set rs4 = db3.OpenRecordset(strSQL)
        Dim dtmDueReturnDate As Date              '应还书日期
        dtmDueReturnDate = rs4.Fields("应还书日期")
        DTReturnDate.Value = dtmReturnDate
        DTDueReturnDate(1).Value = dtmDueReturnDate
        rs4.Edit
        rs4.Fields("还书日期") = dtmReturnDate
        rs4.Fields("还书标志") = True
        rs4.Fields("遗失标志") = chkLost
        rs4.Update
        rs4.Close
        db3.Close
        Set rs4 = Nothing
        Set db3 = Nothing
        
        '向费用库的费用表中添加记录
        Dim sngFeeStyle(3) As Single
        Dim sngAllFee, sngCardFee, sngBorrowFee, sngExceedFee, sngLostFee, sngDeposit, sngAddition As Single
        Dim blnAssoFlag As Boolean
        sngAllFee = 0
        sngCardFee = rs2.Fields("费用")
        sngDeposit = rs1.Fields("押金")
        blnAssoFlag = rs2.Fields("会员标志")
        '如果押金为0,则
        If sngDeposit = 0 Then
            MsgBox "押金已用完,请及时交押金！", vbInformation + vbOKOnly
        End If
        '打开费用库
        strAppName = App.Path & "\费用库.mdb"
        Set db2 = ws.OpenDatabase(strAppName, True, False)          '以独占、可写方式打开数据库
        strSQL = "select * from 价格表"
        Set rs3 = db2.OpenRecordset(strSQL)
        Dim i As Integer
        rs3.MoveFirst
        For i = 1 To 3
            sngFeeStyle(i) = rs3.Fields("费用")
            rs3.MoveNext
        Next i
        rs3.Close
        Set rs3 = Nothing
        '计算借书费用(非会员)
        Dim intDiffDate As Integer
        If Not blnAssoFlag Then
            intDiffDate = DateDiff("d", dtmBorrowDate, dtmReturnDate)
            sngBorrowFee = intDiffDate * sngFeeStyle(1)
            sngAllFee = sngAllFee + sngBorrowFee
        End If
        '如果超期,则罚款
        If dtmReturnDate > dtmDueReturnDate Then
            intDiffDate = DateDiff("d", dtmDueReturnDate, dtmReturnDate)
            sngExceedFee = intDiffDate * sngFeeStyle(2)
            sngAllFee = sngAllFee + sngExceedFee
        End If
        '如果遗失,则罚款
        If chkLost Then
            sngLostFee = sngBookPrice * sngFeeStyle(3)
            sngAllFee = sngAllFee + sngLostFee
        End If
        sngDeposit = sngDeposit - sngAllFee
        If sngDeposit < 0 Then
            sngAddition = -sngDeposit
            sngAddition = Int(sngAddition * 100) / 100
            sngDeposit = 0
        End If
        '向费用表中添加记录
        Set rs3 = db2.OpenRecordset("费用表")
        rs3.AddNew
        rs3.Fields("借书证号") = strCardNo
        rs3.Fields("图书编号") = strBookNo
        rs3.Fields("借书日期") = dtmBorrowDate
        rs3.Fields("应还日期") = dtmDueReturnDate
        rs3.Fields("还书日期") = dtmReturnDate
        If Not blnAssoFlag Then
            rs3.Fields("借书费用") = sngBorrowFee
        End If
        If dtmReturnDate > dtmDueReturnDate Then
            rs3.Fields("超期费用") = sngExceedFee
        End If
        If chkLost Then
            rs3.Fields("遗失费用") = sngLostFee
        End If
        If sngAddition > 0 Then
            rs3.Fields("附加费用") = sngAddition
        End If
        rs3.Fields("总费用") = sngAllFee
        rs3.Fields("押金") = sngDeposit
        rs3.Update
        rs3.Close
        db2.Close
        Set rs3 = Nothing
        Set db2 = Nothing
        '向借书证表中写入押金
        rs1.Edit
        rs1.Fields("押金") = sngDeposit
        rs1.Update
        '显示借书总费用
        Dim strAllFee As String
        If Not blnAssoFlag Then
            strAllFee = "借书费用：" & sngBorrowFee & "元 "
        Else
            strAllFee = "借书费用已包括在会员费中 "
        End If
        If dtmReturnDate > dtmDueReturnDate Then
            strAllFee = strAllFee & "超期罚款：" & sngExceedFee & "元 "
        End If
        If chkLost Then
            strAllFee = strAllFee & "遗失罚款：" & sngLostFee & "元 "
        End If
        strAllFee = strAllFee & "总费用：" & sngAllFee & "元 "
        If sngAddition > 0 Then
            strAllFee = strAllFee & "附加收费：" & sngAddition & "元 "
        End If
        strAllFee = strAllFee & "押金：" & sngDeposit & "元 "
        txtAllFee = strAllFee
        
        '显示在借图书清单
        strAppName = App.Path & "\图书库.mdb"
        strSQL = "select 图书编号,图书名称,出版社,图书种类,图书总数,现存数量,图书价格 from 图书表 where 图书编号='" & strBookNo & "'"
        Data2(1).DatabaseName = strAppName
        Data2(1).RecordSource = strSQL
        DBGrid2(1).Caption = "还书图书情况"
        Data2(1).Refresh
        Data1(1).Refresh
        '如果已还完所有书并且该借书证已到期,则作废
        If intBorrowCount = 0 And dtmNow > dtmValidate Then
            MsgBox "该借书证有效期已到,不能再借书或还书！", vbExclamation + vbOKOnly
            rs1.Edit
            rs1.Fields("作废标志") = True
            rs1.Update
        End If
    Else
        If blnCancelFlag Then
            MsgBox "该借书证已作废！", vbCritical + vbOKOnly
        End If
        If intBorrowCount = 0 Then
            MsgBox "该读者没有所借图书,无法还书！", vbInformation + vbOKOnly
        End If
        If blnLostFlag And intBookCount = 0 Then
            MsgBox "该图书已全部遗失,无法还书！", vbCritical + vbOKOnly
        End If
    End If
    rs2.Close
    rs1.Close
    db1.Close
    Set rs2 = Nothing
    Set rs1 = Nothing
    Set db1 = Nothing
    'rs.Close
    'db.Close
    'Set rs = Nothing
    'Set db = Nothing
    '由于data2与db都绑定图书库,dbdrig2与rs都绑定图书表,所以rs与db都不能关闭
    Exit Sub
ReturnErr:
    MsgBox Err.Description
End Sub

Private Sub cmdRightArrow_Click(Index As Integer)
    On Error GoTo RightErr
    If txtNo(Index) = "" Then
        MsgBox "请输入借书证号！", vbExclamation + vbOKOnly
        txtNo(Index).SetFocus
        Exit Sub
    End If
    '打开借书证库
    Dim strNo As String
    strNo = Trim(txtNo(Index).Text)
    strNo = UCase(strNo)                    '转换为大写字母
    txtNo(Index) = strNo
    strAppName = App.Path & "\借书证库.mdb"
    Set ws = DBEngine.Workspaces(0)
    Set db = ws.OpenDatabase(strAppName, False, True)
    strSQL = "select 借书证号,姓名,借阅数量,作废标志 from 借书证表 where 借书证号='" & strNo & "'"
    Set rs = db.OpenRecordset(strSQL)
    Dim blnCancelFlag As Boolean
    blnCancelFlag = rs.Fields("作废标志")
    If blnCancelFlag = True Then                '如果作废,则退出
        MsgBox "该借书证已作废，请重新输入！", vbCritical + vbOKOnly
        txtNo(Index).SetFocus
        SendKeys "{Home}+{End}"
        Exit Sub
    End If
    txtCardNo(Index).Text = rs.Fields("借书证号")
    txtName(Index).Text = rs.Fields("姓名")
    txtBorrowCount(Index).Text = rs.Fields("借阅数量")
    rs.Close
    db.Close
    Set rs = Nothing
    Set db = Nothing
    '打开读者库
    strNo = Mid(strNo, 2)
    strAppName = App.Path & "\读者库.mdb"
    Set db = ws.OpenDatabase(strAppName, False, True)
    strSQL = "select 单位部门,读者类别,借书次数 from 读者表 where 读者编号='" & strNo & "'"
    Set rs = db.OpenRecordset(strSQL)
    txtDepartment(Index).Text = rs.Fields("单位部门")
    txtClass(Index).Text = rs.Fields("读者类别")
    txtBorrowTime(Index).Text = rs.Fields("借书次数")
    rs.Close
    db.Close
    Set rs = Nothing
    Set db = Nothing
    '打开图书库
    strAppName = App.Path & "\图书库.mdb"
    strSQL = "select 图书编号,图书名称,出版社,图书种类,图书总数,现存数量,图书价格 from 图书表"
    Data1(Index).DatabaseName = strAppName
    Data1(Index).RecordSource = strSQL
    DBGrid1(Index).Caption = "所有图书情况"
    Data1(Index).Refresh
    If Index = 0 Then
        cmdBorrow.Enabled = True
    Else
        cmdReturn.Enabled = True
        chkLost.Enabled = True
    End If
    cmdBorrowRecord(Index).Enabled = True
    Exit Sub
RightErr:
    MsgBox Err.Description
End Sub

Private Sub Data1_Reposition(Index As Integer)
    Data1(Index).Caption = "图书记录:" & Data1(Index).Recordset.AbsolutePosition + 1
    '打开图书库,给图书编号和图书名称赋值
    strAppName = App.Path & "\图书库.mdb"
    Set ws = DBEngine.Workspaces(0)
    Set db = ws.OpenDatabase(strAppName, False, True)
    strSQL = "select count(*) as 总数 from 图书表"
    Set rs = db.OpenRecordset(strSQL)
    Dim i, intCount As Long
    intCount = rs.Fields("总数")
    rs.Close
    Set rs = Nothing
    strSQL = "select 图书编号,图书名称 from 图书表"
    Set rs = db.OpenRecordset(strSQL)
    rs.MoveFirst
    For i = 1 To intCount
        If i = Data1(Index).Recordset.AbsolutePosition + 1 Then
            txtBookNo(Index).Text = rs.Fields("图书编号")
            txtBookName(Index).Text = rs.Fields("图书名称")
            Exit For
        End If
        rs.MoveNext
    Next i
    rs.Close
    db.Close
    Set rs = Nothing
    Set db = Nothing
End Sub

Private Sub Data2_Reposition(Index As Integer)
    Data2(Index).Caption = "图书记录:" & Data2(Index).Recordset.AbsolutePosition + 1
End Sub

Private Sub Form_Activate()
    txtNo(BRState).SetFocus
End Sub

Private Sub Form_Load()
    OFFCAT.Play "wave"
    If BRState = 0 Then
        SSTab1.Tab = 0              '借书作业
    Else
        SSTab1.Tab = 1              '还书作业
    End If
    strName(1) = "图书编号": strType(1) = dbText: strSize(1) = 20
    strName(2) = "图书名称": strType(2) = dbText: strSize(2) = 50
    strName(3) = "出版社": strType(3) = dbText: strSize(3) = 20
    strName(4) = "图书种类": strType(4) = dbText: strSize(4) = 20
    strName(5) = "图书总数": strType(5) = dbInteger: strSize(5) = 2
    strName(6) = "现存数量": strType(6) = dbInteger: strSize(6) = 2
    strName(7) = "图书价格": strType(7) = dbCurrency: strSize(7) = 8
End Sub

Private Sub Form_Resize()
    SSTab1.Left = (Me.Width - SSTab1.Width) / 2
End Sub

Private Function ExistTable(db As Database, tblName As String) As Boolean       '判断表是否存在
    Dim tbldef As TableDef
    For Each tbldef In db.TableDefs
        If tbldef.Name = tblName Then
            ExistTable = True           '表存在
            Set tbldef = Nothing
            Exit Function
        End If
    Next
    ExistTable = False              '表不存在
End Function