frmmoneycard.frm

本系统可用于医院和专业体检中心的健康体检管理

RollBack:
    GCon.RollbackTrans
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdCancelCard_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim itmCard As ListItem
    Dim strCardID As String
    Dim curMoney As Currency
    
    Me.MousePointer = vbHourglass
    
    '是否有输入
    strCardID = Trim(txtCardID.Text)
    '卡号是否为空
    If strCardID = "" Then
        MsgBox "请输入要注销的卡号！", vbInformation, "提示"
        txtCardID.SetFocus
        GoTo ExitLab
    End If
    
    '卡号是否存在
    strSQL = "select CardID,CardBalance from SET_MONEYCARD" _
            & " where CardID='" & strCardID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rstemp.EOF Then
        '余额是否为零
        If rstemp("CardBalance") > 0 Then
            If MsgBox("卡号 “" & strCardID & "” 尚存余额 " & rstemp("CardBalance") & " 元。" _
                    & vbCrLf & "确实要注销改卡吗？" _
                    , vbExclamation + vbYesNo + vbDefaultButton2, "警告") = vbNo Then
                txtCardID.SetFocus
                GoTo ExitLab
            End If
        End If
        
        rstemp.Close
    Else
        MsgBox "您输入的卡号不存在。请核对后重新输入！", _
                vbInformation, "提示"
        txtCardID.SetFocus
        GoTo ExitLab
    End If
    
    '提示
    If MsgBox("该操作不可恢复，将同时删除该卡号的所有消费记录！" _
            & vbCrLf & "您确实要注销卡号 “" & strCardID & "” 吗？", _
            vbExclamation + vbYesNo + vbDefaultButton2, "警告") = vbNo Then
        txtCardID.SetFocus
        GoTo ExitLab
    End If
    
    '权限验证
    If gstrClassifyID <> GManager.SystemXTGL Then
        MsgBox "请用管理员帐户登录！", vbExclamation, "警告"
        txtCardID.SetFocus
        GoTo ExitLab
    End If
    
    '在事务中进行注销
    GCon.BeginTrans
    On Error GoTo RollBack
    '删除消费信息表
    strSQL = "delete from SET_MONEYCARD_CONSUME" _
            & " where CardID='" & strCardID & "'"
    GCon.Execute strSQL
    
    '删除代金卡主表
    strSQL = "delete from SET_MONEYCARD" _
            & " where CardID='" & strCardID & "'"
    GCon.Execute strSQL
    '提交事务
    GCon.CommitTrans
    
    '在列表中删除
    If Not (lvwMoneyCard.FindItem(strCardID, lvwText) Is Nothing) Then
        Call DeleteItemFromListView(lvwMoneyCard, lvwMoneyCard.SelectedItem.Index)
        lvwMoneyCard_Click
    End If
    
    '提示
    MsgBox "注销成功！", vbInformation, "提示"
    txtCardID.Text = ""
    txtMoney.Text = ""
    
    '跳转焦点
    txtCardID.SetFocus
    
    GoTo ExitLab
RollBack:
    GCon.RollbackTrans
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdQuery_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim itmCard As ListItem
    
    Me.MousePointer = vbHourglass
    
    '清除上次可能存在的查询结果
    lvwMoneyCard.ListItems.Clear
    
    '清除空格
    txtMoneyCard.Text = Trim(txtMoneyCard.Text)
    '是否为空
    If txtMoneyCard.Text = "" Then
        If MsgBox("您没有输入任何查询条件，这将显示所有存在的记录，并花费较多时间，" _
                & "具体时间视数据多少而定。" & vbCrLf & "确实要继续吗？", _
                vbQuestion + vbYesNo + vbDefaultButton2, "提示") = vbNo Then
            txtMoneyCard.SetFocus
            GoTo ExitLab
        End If
    End If
    
    '查找满足条件的所有记录
    strSQL = "select CardID,CardBalance,SendTime,StopTime" _
            & " from SET_MONEYCARD" _
            & " where CardID like '%" & txtMoneyCard.Text & "%'" _
            & " order by SendTime desc"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rstemp.EOF Then
        MsgBox "没有找到匹配记录，请重新输入查询条件！", vbInformation, "提示"
        txtMoneyCard.SetFocus
        GoTo ExitLab
    Else
        '显示查询结果
        Do
            Set itmCard = lvwMoneyCard.ListItems.Add(, HEADER & rstemp("CardID"), rstemp("CardID"))
            itmCard.SubItems(1) = rstemp("CardBalance")
            itmCard.SubItems(2) = rstemp("SendTime")
            itmCard.SubItems(3) = rstemp("StopTime") & ""
            
            rstemp.MoveNext
        Loop While Not rstemp.EOF
        
        Set lvwMoneyCard.SelectedItem = lvwMoneyCard.ListItems(1)
        lvwMoneyCard_Click
        
        rstemp.Close
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdSendCard_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsCard As ADODB.Recordset
    Dim strCardID As String
    Dim curCardMoney As Currency
    Dim dtmNow As Date
    Dim dtmStopTime As Date
    
    Me.MousePointer = vbHourglass
    
    '清除空格
    txtCardID.Text = Trim(txtCardID.Text)
    strCardID = txtCardID.Text
    '是否为空
    If strCardID = "" Then
        MsgBox "请输入要发放的卡号！", vbInformation, "提示"
        txtCardID.SetFocus
        GoTo ExitLab
    End If
    
    '检查该卡号是否已经存在
    strSQL = "select Count(*) from SET_MONEYCARD" _
            & " where CardID='" & strCardID & "'"
    Set rsCard = New ADODB.Recordset
    rsCard.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rsCard(0) >= 1 Then
        MsgBox "您输入的卡号已经存在，请核对后重新输入！", vbExclamation, "提示"
        txtCardID.SetFocus
        GoTo ExitLab
    End If
    
    '金额
    curCardMoney = CCur(Val(txtMoney.Text))
    '有效期
    dtmStopTime = dtpStopTime.Value
    '是否有效
    If dtmStopTime <= Date Then
        MsgBox "您输入的有效期不合理，请核对后重新输入！", vbExclamation, "警告"
        dtpStopTime.SetFocus
        GoTo ExitLab
    End If
    
    '确认
    If MsgBox("已经准备就绪，新发放卡的信息如下：" _
            & vbCrLf & "卡号：" & strCardID _
            & vbCrLf & "金额：" & CStr(curCardMoney) _
            & vbCrLf & "有效期至：" & CStr(dtmStopTime) _
            & vbCrLf & vbCrLf & "确实要发放该卡吗？", vbQuestion + vbYesNo + vbDefaultButton1 _
            , "小心") = vbNo Then GoTo ExitLab
            
    '在事务中发放新卡
    GCon.BeginTrans
    On Error GoTo RollBack
    '首先插入一条空记录
    strSQL = "insert into SET_MONEYCARD(CardID)" _
            & " values('" & strCardID & "')"
    GCon.Execute strSQL
    
    dtmNow = Now
    '更新其余字段
    strSQL = "update SET_MONEYCARD set" _
            & " CardBalance=" & curCardMoney _
            & ",SendTime='" & dtmNow & "'" _
            & ",StopTime='" & dtmStopTime & "'" _
            & ",EmployeeID=" & gintManagerID _
            & " where CardID='" & strCardID & "'"
    GCon.Execute strSQL
    
    If CardConsume(strCardID, True, curCardMoney, dtmNow, "发卡") = False Then GoTo RollBack
    '提交事务
    GCon.CommitTrans
    
    '提示
    MsgBox "发卡成功！", vbInformation, "提示"
    txtCardID.Text = ""
    txtMoney.Text = ""
    
    '跳转焦点
    txtCardID.SetFocus
    
'    CmdQuery_Click
'    '定位到当前添加的卡号
'    Call lvwMoneyCard.FindItem(strCardID)
'    lvwMoneyCard_Click
    
    GoTo ExitLab
RollBack:
    GCon.RollbackTrans
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
    Me.Left = 20
    Me.Top = 30
    Me.Width = 12540
    Me.Height = 9405
    
    '有效期默认为一年
    dtpStopTime.Value = DateAdd("yyyy", 1, Date)
End Sub

Private Sub lvwMoneyCard_Click()
On Error GoTo ErrMsg
    Dim itmCard As ListItem
    Dim strCardID As String
    Dim Status
    Dim strSQL As String
    Dim rsInfo As ADODB.Recordset
    Dim itmInfo As ListItem
    
    Me.MousePointer = vbHourglass
    
    '清除消费记录
    lvwConsumeInfo.ListItems.Clear
    
    '是否有选择
    Set itmCard = lvwMoneyCard.SelectedItem
    If itmCard Is Nothing Then
        GoTo ExitLab
    End If
    
    '记录ID
    strCardID = Mid(itmCard.Key, 2)
    '在录入框里面显示卡号
'    txtMoneyCard.Text = strCardID
'    txtMoneyCard_LostFocus
    
    '显示消费记录
    strSQL = "select ConsumeMoney,ConsumeTime,IsAppend,Memo,RY_Employee.Name" _
            & " from SET_MONEYCARD_CONSUME,RY_Employee" _
            & " where CardID='" & strCardID & "'" _
            & " and SET_MONEYCARD_CONSUME.EmployeeID=RY_Employee.EmployeeID" _
            & " order by ConsumeTime"
    Set rsInfo = New ADODB.Recordset
    rsInfo.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rsInfo.EOF Then
        Do
            Set itmInfo = lvwConsumeInfo.ListItems.Add(, , rsInfo("ConsumeTime"))
            If rsInfo("IsAppend") Then
                itmInfo.SubItems(1) = rsInfo("ConsumeMoney")
            Else
                itmInfo.SubItems(2) = rsInfo("ConsumeMoney")
            End If
            itmInfo.SubItems(3) = rsInfo("Memo") & ""
            itmInfo.SubItems(4) = rsInfo("Name") & ""
            
            rsInfo.MoveNext
        Loop While Not rsInfo.EOF
        
        rsInfo.Close
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub lvwMoneyCard_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyUp Or KeyCode = vbKeyDown Then
        lvwMoneyCard_Click
    End If
End Sub

Private Sub txtCardID_GotFocus()
    txtCardID.SelStart = 0
    txtCardID.SelLength = Len(txtCardID.Text)
End Sub

Private Sub txtCardID_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        txtMoney.SetFocus
    End If
End Sub

Private Sub txtCardID_LostFocus()
On Error Resume Next
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strCardID As String
    
    Me.MousePointer = vbArrowHourglass
    
    '是否输入了卡号
    strCardID = Trim(txtCardID.Text)
    txtCardID.Text = strCardID
    If strCardID = "" Then GoTo ExitLab
    
    '检查卡号是否已经存在
    strSQL = "select StopTime from SET_MONEYCARD" _
            & " where CardID='" & strCardID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rstemp.EOF Then
        If Not IsNull(rstemp("StopTime")) Then
            dtpStopTime.Value = rstemp("StopTime")
        End If
        rstemp.Close
    End If
            
    
    GoTo ExitLab
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub txtMoneyCard_GotFocus()
    txtMoneyCard.SelStart = 0
    txtMoneyCard.SelLength = Len(txtMoneyCard.Text)
End Sub

Private Sub txtMoneyCard_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        cmdQuery_Click
        txtMoneyCard.SetFocus
    End If
End Sub

Private Sub txtMoneyCard_LostFocus()
    txtMoneyCard_GotFocus
End Sub

Private Sub XPCommandButton3_Click()
    Unload Me
End Sub