frmlibcardmanager.frm

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

            X1              =   8400
            X2              =   8400
            Y1              =   240
            Y2              =   2280
         End
      End
      Begin VB.Data Data1 
         Connect         =   "Access 2000;"
         DatabaseName    =   ""
         DefaultCursorType=   0  '缺省游标
         DefaultType     =   2  '使用 ODBC
         Exclusive       =   0   'False
         Height          =   405
         Left            =   120
         Options         =   0
         ReadOnly        =   0   'False
         RecordsetType   =   1  'Dynaset
         RecordSource    =   ""
         Top             =   8280
         Width           =   10215
      End
   End
End
Attribute VB_Name = "frmLibCardManager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim intIndex As Long              '某类别的借书证总数递增号
Dim strNo As String             '相应的读者编号
Dim ws As Workspace, db As Database, db1 As Database, rs As Recordset, rs1 As Recordset

Private Sub cmdAddNew_Click()
    On Error GoTo AddErr
    cmdDelete.Enabled = Not cmdDelete.Enabled
    cmdUpdate.Enabled = Not cmdUpdate.Enabled
    cmdRefresh.Enabled = Not cmdRefresh.Enabled
    If Left(cmdAddNew.Caption, 2) = "新增" Then
        cmdAddNew.Caption = "确认(&O)"
        cmdClose.Caption = "放弃(&C)"
        cmdGenerate.Enabled = True
        cmdData.Enabled = True
        DBComCardSort.Enabled = True
        'Data1.Recordset.MoveLast
        Data1.Recordset.AddNew
        'txtName.SetFocus
    Else
        DTRegisterDate.Value = FormatDateTime(Now, vbShortDate)
        cmdAddNew.Caption = "新增(&A)"
        cmdClose.Caption = "关闭(&C)"
        cmdGenerate.Enabled = False
        cmdData.Enabled = False
        DBComCardSort.Enabled = False
        '更新数据控件
        Data1.Recordset.Update
        Data1.Recordset.MoveLast
    End If
    Exit Sub
AddErr:
    MsgBox Err.Description
End Sub

Private Sub cmdClose_Click()
    On Error GoTo CloseErr
    If Left(cmdClose.Caption, 2) = "放弃" Then
        cmdClose.Caption = "关闭(&C)"
        cmdGenerate.Enabled = False
        cmdData.Enabled = False
        DBComCardSort.Enabled = False
        cmdAddNew.Caption = "新增(&A)"
        cmdAddNew.Enabled = True
        cmdDelete.Enabled = True
        cmdUpdate.Enabled = True
        cmdRefresh.Enabled = True
        Data1.UpdateControls
        If Not (Data1.Recordset.BOF And Data1.Recordset.EOF) Then Data1.Recordset.MoveLast  '记录不为空,则移到最后
    Else
        Unload Me
    End If
    Exit Sub
CloseErr:
    MsgBox Err.Description
End Sub

Private Sub cmdData_Click()
    On Error GoTo DataErr
    Dim strAppName As String, strSQL As String
    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)
    txtName.Text = rs.Fields("读者姓名")
    txtSex.Text = rs.Fields("性别")
    txtAge.Text = rs.Fields("年龄")
    txtClass.Text = rs.Fields("单位部门")
    rs.Close
    db.Close
    Set rs = Nothing
    Set db = Nothing
    cmdData.Enabled = False
    Exit Sub
DataErr:
    MsgBox Err.Description
End Sub

Private Sub cmdDelete_Click()
    On Error GoTo DeleteErr
    With Data1.Recordset
        .Delete
        .MoveNext
        If .EOF Then .MoveLast
    End With
    Exit Sub
DeleteErr:
    MsgBox Err.Description
End Sub

Private Sub cmdDeposit_Click()
    On Error GoTo DepErr
    Dim sngDeposit As Single
    sngDeposit = CSng(txtDeposit)           '将文本框转换为单精度数字
    If sngDeposit > 0 Then
        MsgBox "当前记录的押金不为零,不能预交押金！", vbExclamation + vbOKOnly
        Exit Sub
    End If
    Dim strSort, strShort As String
    strSort = Trim(txtNo)
    strShort = Mid(strSort, 1, 1)
    Dim strAppName, strSQL As String
    strAppName = App.Path & "\借书证库.mdb"
    Set db = DBEngine.OpenDatabase(strAppName, True, False)         '独占、可写
    strSQL = "select 押金 from 借书证类型表 where 借书证类型='" & strShort & "'"
    Set rs = db.OpenRecordset(strSQL)
    sngDeposit = rs.Fields("押金")
    rs.Close
    Set rs = Nothing
    strSQL = "select 押金 from 借书证表 where 借书证号='" & strSort & "'"
    Set rs = db.OpenRecordset(strSQL)
    rs.Edit
    rs.Fields("押金") = sngDeposit
    rs.Update
    rs.Close
    Set rs = Nothing
    txtDeposit = CStr(sngDeposit)
    db.Close
    Set db = Nothing
    Data1.Refresh
    MsgBox "押金已预交！", vbInformation + vbOKOnly
    Exit Sub
DepErr:
    MsgBox Err.Description
End Sub

Private Sub cmdFirst_Click()
    If Not Data1.Recordset.BOF Then Data1.Recordset.MoveFirst
End Sub

Private Sub cmdGenerate_Click()
    On Error GoTo GeneErr
    Dim strAppName As String, strSQL As String
    strAppName = App.Path & "\借书证库.mdb"
    Set ws = DBEngine.Workspaces(0)
    Set db = ws.OpenDatabase(strAppName, False, True)
    '找到该类别的类别简称号
    Dim strCardSort As String, strCardShort As String
    strCardSort = DBComCardSort.Text
    If strCardSort = "" Or Asc(strCardSort) = 32 Then
        db.Close
        'ws.Close
        Set db = Nothing
        'Set ws = Nothing
        GoTo GeneErr
    End If
    strSQL = "select 借书证类型 from 借书证类型表 where 类型名称='" & strCardSort & "'"
    Set rs = db.OpenRecordset(strSQL)
    strCardShort = rs.Fields("借书证类型")
    rs.Close
    db.Close
    Set rs = Nothing
    Set db = Nothing
    '找到与读者表中对应的借书证记录
    strAppName = App.Path & "\读者库.mdb"
    Set db = DBEngine.OpenDatabase(strAppName, False, True)
    strSQL = "select * from 读者表 order by 读者编号"
    Set rs = db.OpenRecordset(strSQL)
    strAppName = App.Path & "\借书证库.mdb"
    Set db1 = DBEngine.OpenDatabase(strAppName, False, True)
    strSQL = "select * from 借书证表 order by mid([借书证号],2)"
    Set rs1 = db1.OpenRecordset(strSQL)
    rs.MoveFirst
    rs1.MoveFirst
    intIndex = 0
    Do While Not (rs.EOF And rs1.EOF)
        If Mid(rs1.Fields("借书证号"), 2) <> rs.Fields("读者编号") Then
            Exit Do
        Else
            intIndex = intIndex + 1
        End If
        rs1.MoveNext
        rs.MoveNext
    Loop
    rs1.Close
    Set rs1 = Nothing
    rs.Close
    Set rs = Nothing
    db.Close
    Set db = Nothing
    '找到相应读者库中读者表中的记录,取出读者编号
    strAppName = App.Path & "\读者库.mdb"
    Set db = ws.OpenDatabase(strAppName, False, True)
    strSQL = "select 读者编号 from 读者表"
    Set rs = db.OpenRecordset(strSQL)
    If rs.RecordCount = 0 Then
        MsgBox "读者库为空,不能添加记录,请先添加读者！", vbExclamation + vbOKOnly
        cmdClose_Click
        Exit Sub
    Else
        rs.Move intIndex
        If rs.EOF Then
            MsgBox "已添加完借书证库,请再添加读者！", vbExclamation + vbOKOnly
            cmdClose_Click
            Exit Sub
        End If
        strNo = Trim(rs.Fields("读者编号"))
    End If
    '生成借书证编号
    txtNo.Text = strCardShort & strNo
    rs.Close
    db.Close
    'ws.Close
    Set rs = Nothing
    Set db = Nothing
    'Set ws = Nothing
    '总结：由于用对象变量DAO打开数据库和用Data控件打开数据库用的是同一工作区，所以不能关闭工作区。
    DBComCardSort.Enabled = False
    cmdGenerate.Enabled = False
    Exit Sub
GeneErr:
    MsgBox Err.Description
End Sub

Private Sub cmdLast_Click()
    If Not Data1.Recordset.EOF Then Data1.Recordset.MoveLast
End Sub

Private Sub cmdNext_Click()
    If Data1.Recordset.BOF And Data1.Recordset.EOF Then Exit Sub        '如果记录为空,则退出
    Data1.Recordset.MoveNext
    If Data1.Recordset.EOF Then Data1.Recordset.MoveLast
End Sub

Private Sub cmdPrevious_Click()
    If Data1.Recordset.BOF And Data1.Recordset.EOF Then Exit Sub        '如果记录为空,则退出
    Data1.Recordset.MovePrevious
    If Data1.Recordset.BOF Then Data1.Recordset.MoveFirst
End Sub

Private Sub cmdRefresh_Click()
    '只有多用户应用程序需要
    On Error GoTo RefreshErr
    Data1.Refresh
    Exit Sub
RefreshErr:
    MsgBox Err.Description
End Sub

Private Sub cmdUpdate_Click()
    On Error GoTo UpdateErr
    Data1.UpdateRecord
    Exit Sub
UpdateErr:
    MsgBox Err.Description
End Sub

Private Sub Data1_Reposition()
    Data1.Caption = "借书证记录:" & Data1.Recordset.AbsolutePosition + 1
End Sub

Private Sub Form_Load()
    OFFCAT.Play "wave"
    Dim rs1 As Recordset
    Dim strAppName As String, strSQL As String
    strAppName = App.Path & "\借书证库.mdb"
    '判断借书证是否作废
    Set ws = DBEngine.Workspaces(0)
    Set db = ws.OpenDatabase(strAppName, True, False)                   '以独占、可写方式打开数据库
    Set rs = db.OpenRecordset("select * from 借书证表")
    Dim i, intCount As Integer
    Dim dtmRegister As Date, dtmNow As Date, strNo As String, strSort As String, sngAvailable As Single, blnCancel As Boolean
    intCount = rs.RecordCount
    If intCount <> 0 Then
        rs.MoveFirst
        For i = 1 To intCount
            blnCancel = rs.Fields("作废标志")
            If blnCancel = False Then
                dtmRegister = rs.Fields("登记日期")
                dtmNow = FormatDateTime(Now, vbShortDate)
                strSort = rs.Fields("借书证类型")
                strSQL = "select 有效日期 from 借书证类型表 where 借书证类型='" & strSort & "'"
                Set rs1 = db.OpenRecordset(strSQL)
                sngAvailable = rs1.Fields("有效日期")
                rs1.Close
                Set rs1 = Nothing
                If DateDiff("d", dtmRegister, dtmNow) > sngAvailable * 365 Then
                    strNo = rs.Fields("借书证号")
                    blnCancel = True
                    rs.Edit
                    rs.Fields("作废标志") = blnCancel
                    rs.Update
                    MsgBox "借书证" & strNo & "有效期已到,现将其作废！", vbInformation + vbOKOnly
                End If
            End If
            rs.MoveNext
        Next i
    End If
    rs.Close
    Set rs = Nothing
    '打开借书证库
    strSQL = "select 借书证号,姓名,性别,年龄,班级,登记日期,借书证类型,押金 from 借书证表 where 作废标志=False"
    Data1.DatabaseName = strAppName
    Data1.RecordSource = strSQL
    strSQL = "select 借书证类型,类型名称 from 借书证类型表"
    Data2.DatabaseName = strAppName
    Data2.RecordSource = strSQL
    '给字段赋属性值
    txtNo.DataField = "借书证号": txtName.DataField = "姓名": txtSex.DataField = "性别"
    txtAge.DataField = "年龄": txtClass.DataField = "班级": DTRegisterDate.DataField = "登记日期"
    txtDeposit.DataField = "押金"
    DBComCardSort.DataField = "借书证类型": DBComCardSort.BoundColumn = "借书证类型": DBComCardSort.ListField = "类型名称"
End Sub

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