frmmembers.frm

这是一个图书馆数据库系统

      Left            =   120
      TabIndex        =   8
      Top             =   1340
      Width           =   1815
   End
   Begin VB.Label lblLabels 
      Caption         =   "加入时间:"
      Height          =   255
      Index           =   3
      Left            =   120
      TabIndex        =   6
      Top             =   1020
      Width           =   1815
   End
   Begin VB.Label lblLabels 
      Caption         =   "名:"
      Height          =   255
      Index           =   2
      Left            =   120
      TabIndex        =   4
      Top             =   700
      Width           =   1815
   End
   Begin VB.Label lblLabels 
      Caption         =   "姓:"
      Height          =   255
      Index           =   1
      Left            =   120
      TabIndex        =   2
      Top             =   380
      Width           =   1815
   End
   Begin VB.Label lblLabels 
      Caption         =   "会员编号:"
      Height          =   255
      Index           =   0
      Left            =   120
      TabIndex        =   0
      Top             =   60
      Width           =   1815
   End
End
Attribute VB_Name = "frmMembers"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim WithEvents adoprimaryrs As Recordset
Attribute adoprimaryrs.VB_VarHelpID = -1
Dim mbChangedByCode As Boolean
Dim mvBookMark As Variant
Dim mbEditFlag As Boolean
Dim mbAddNewFlag As Boolean
Dim mbDataChanged As Boolean
Private Sub cmdSearch_Click()
    txtSearch = Trim(txtSearch)
    adoprimaryrs.MoveFirst
    adoprimaryrs.Find (comSearch.Text & "='" & txtSearch & "'")
    If adoprimaryrs.AbsolutePosition < 0 Then
        MsgBox comSearch & " 没找到!!!", vbInformation, "注意"
        adoprimaryrs.MoveFirst
    End If
End Sub

Private Sub Form_Load()
    Dim db As Connection
    Set db = New Connection
    db.CursorLocation = adUseClient
    db.Open strConnection

    Set adoprimaryrs = New Recordset
    adoprimaryrs.Open "select MemberId,FirstName,LastName,DateOfJoining,DateOfExpire,BooksInHand,FineBal,Address,Tel,Email from Members", db, adOpenStatic, adLockOptimistic

    Dim oText As TextBox
    '绑定Textbox到数据源
    For Each oText In Me.txtFields
        Set oText.DataSource = adoprimaryrs
    Next

    mbDataChanged = False
    comSearch.AddItem ("MemberId")
    comSearch.AddItem ("FirstName")
    comSearch.AddItem ("LastName")
    comSearch.ListIndex = 0
  
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    lblStatus.Width = Me.Width - 1500
    cmdNext.Left = lblStatus.Width + 700
    cmdLast.Left = cmdNext.Left + 340
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Screen.MousePointer = vbDefault
End Sub

Private Sub adoPrimaryRS_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
    '显示现在记录
    lblStatus.Caption = "记录: " & CStr(adoprimaryrs.AbsolutePosition)
End Sub

Private Sub adoPrimaryRS_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
    '这里是放置验证代码的地方
    '下面这些事件激发此事件发生
    Dim bCancel As Boolean

      Select Case adReason
        Case adRsnAddNew
        Case adRsnClose
        Case adRsnDelete
        Case adRsnFirstChange
        Case adRsnMove
        Case adRsnRequery
        Case adRsnResynch
        Case adRsnUndoAddNew
        Case adRsnUndoDelete
        Case adRsnUndoUpdate
        Case adRsnUpdate
      End Select
    
      If bCancel Then adStatus = adStatusCancel
End Sub

Private Sub cmdAdd_Click()
    On Error GoTo AddErr
    With adoprimaryrs
        If Not (.BOF And .EOF) Then
            mvBookMark = .Bookmark
        End If
        .AddNew
        lblStatus.Caption = "添加记录"
        mbAddNewFlag = True
        SetButtons False
    End With
    '指定会员加入时间为当前日期
    txtFields(3).Text = Date
    '计算会员资格到期时间
    txtFields(4).Text = DateAdd("m", M.MembershipDuration, Date)
    '将会员当前借书数量清零
    txtFields(5).Text = "0" 'books in hand
    '添加由于支付会费所导致的账户欠款
    txtFields(6).Text = M.MembershipFee
    Exit Sub

AddErr:
    MsgBox "发生错误：" & Err.Description, vbExclamation, "错误"
End Sub

Private Sub cmdDelete_Click()
    On Error GoTo DeleteErr
    '还有书籍未归还
    If adoprimaryrs.Fields(5) > 0 Then
        MsgBox "这个会员需要归还所有借出书籍才能被删除", vbInformation
        Exit Sub
    End If
    '账户还有欠款未支付
    If adoprimaryrs.Fields(6) > 0 Then
        MsgBox "这个会员需要支付完所有欠款才能被删除", vbInformation
        Exit Sub
    End If

    With adoprimaryrs
        .Delete
        .MoveNext
        If .EOF Then .MoveLast
    End With
    Exit Sub

DeleteErr:
    MsgBox "发生错误：" & Err.Description, vbExclamation, "错误"
End Sub

Private Sub cmdRefresh_Click()
  On Error GoTo RefreshErr
    adoprimaryrs.Requery
    Exit Sub
RefreshErr:
    MsgBox "发生错误：" & Err.Description, vbExclamation, "错误"
End Sub

Private Sub cmdEdit_Click()
    On Error GoTo EditErr

    lblStatus.Caption = "编辑记录"
    mbEditFlag = True
    SetButtons False
    Exit Sub

EditErr:
    MsgBox "发生错误：" & Err.Description, vbExclamation, "错误"
End Sub
Private Sub cmdCancel_Click()
    On Error Resume Next

    SetButtons True
    mbEditFlag = False
    mbAddNewFlag = False
    adoprimaryrs.CancelUpdate
    If mvBookMark > 0 Then
        adoprimaryrs.Bookmark = mvBookMark
    Else
        adoprimaryrs.MoveFirst
    End If
    mbDataChanged = False

End Sub

Private Sub cmdUpdate_Click()
    On Error GoTo UpdateErr

    adoprimaryrs.UpdateBatch adAffectAll

    If mbAddNewFlag Then
        '移动到新纪录
        adoprimaryrs.MoveLast
    End If

    mbEditFlag = False
    mbAddNewFlag = False
    SetButtons True
    mbDataChanged = False

    Exit Sub
UpdateErr:
    MsgBox "发生错误：" & Err.Description, vbExclamation, "错误"
End Sub

Private Sub cmdClose_Click()
  Unload Me
End Sub

Private Sub cmdFirst_Click()
    On Error GoTo GoFirstError

    adoprimaryrs.CancelUpdate

    adoprimaryrs.MoveFirst
    mbDataChanged = False

    Exit Sub

GoFirstError:
    MsgBox "发生错误：" & Err.Description, vbExclamation, "错误"
End Sub

Private Sub cmdLast_Click()
    On Error GoTo GoLastError

    adoprimaryrs.CancelUpdate
    adoprimaryrs.MoveLast
    mbDataChanged = False
    Exit Sub

GoLastError:
    MsgBox "发生错误：" & Err.Description, vbExclamation, "错误"
End Sub

Private Sub cmdNext_Click()
    On Error GoTo GoNextError
    adoprimaryrs.CancelUpdate
    If Not adoprimaryrs.EOF Then adoprimaryrs.MoveNext
    If adoprimaryrs.EOF And adoprimaryrs.RecordCount > 0 Then
        Beep
        '超出记录尾，需要恢复
        adoprimaryrs.MoveLast
    End If
    '显示现在记录
    mbDataChanged = False

    Exit Sub
GoNextError:
    MsgBox "发生错误：" & Err.Description, vbExclamation, "错误"
End Sub

Private Sub cmdPrevious_Click()
    On Error GoTo GoPrevError
    adoprimaryrs.CancelUpdate

    If Not adoprimaryrs.BOF Then adoprimaryrs.MovePrevious
    If adoprimaryrs.BOF And adoprimaryrs.RecordCount > 0 Then
        Beep
        '超出记录头，需要恢复
        adoprimaryrs.MoveFirst
    End If
    '显示现在记录
    mbDataChanged = False

    Exit Sub

GoPrevError:
    MsgBox "发生错误：" & Err.Description, vbExclamation, "错误"

End Sub

Private Sub SetButtons(bVal As Boolean)
      cmdAdd.Visible = bVal
      cmdEdit.Visible = bVal
      cmdUpdate.Visible = Not bVal
      cmdCancel.Visible = Not bVal
      cmdDelete.Visible = bVal
      cmdClose.Visible = bVal
      cmdRefresh.Visible = bVal
      cmdNext.Enabled = bVal
      cmdFirst.Enabled = bVal
      cmdLast.Enabled = bVal
      cmdPrevious.Enabled = bVal
      Frame1.Enabled = bVal
      txtFields(0).Enabled = Not bVal
  End Sub


Private Sub txtFields_LostFocus(Index As Integer)
    If Index = 8 And Not IsNumeric(txtFields(Index).Text) Then
        MsgBox "输入电话号码!!!", vbInformation, "注意"
        txtFields(Index).Text = ""
        txtFields(Index).SetFocus
    End If

End Sub