dlgpaymoney.frm

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

        Else
            '修改
            Set itmTemp = .SelectedItem
        End If
        itmTemp.SubItems(1) = cmbZFFS.Text
        itmTemp.SubItems(2) = txtSShou.Text
        
        '计算合计
        curTotal = 0
        For i = 1 To lvwSFHistory.ListItems.Count - 1
            curTotal = curTotal + CCur(Val(lvwSFHistory.ListItems(i).SubItems(2)))
        Next i
        '修改合计
        Set itmTemp = .ListItems(.ListItems.Count)
        itmTemp.SubItems(2) = CStr(curTotal)
    End With
    '调用单击事件
    lvwSFHistory_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 cmdTotalSave_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim lngGUID As String
    
    Me.MousePointer = vbHourglass
    
    '校验成交价格
    txtYSTotal.Text = Val(txtYSTotal.Text)
    If Val(txtYSTotal.Text) <= 0 Then
        MsgBox "成交价格必须大于零！", vbInformation, "提示"
        txtYSTotal.SetFocus
        GoTo ExitLab
    End If
    
    '写入数据库
    strSQL = "update SET_GRXX set" _
            & " CJJG=" & CCur(Val(txtYSTotal.Text)) _
            & ",XMJG=" & CCur(Val(Mid(lblTotalMoney.Caption, InStr(1, lblTotalMoney.Caption, "：") + 1))) _
            & ",PriceMemo='" & txtPriceMemo.Text & "'" _
            & " where GUID=" & mlngGUID
    GCon.Execute strSQL
    '禁用保存按钮
    cmdTotalSave.Enabled = False
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'**************************************************************
'被调函数
'参数1：客户GUID
'返回值：Currency，本次成交费用
'**************************************************************
Public Function ShowPersonMoney(ByVal lngGUID As Long, _
        Optional ByVal blnEnablePrice As Boolean = True, _
        Optional ByVal blnEnableCharging As Boolean = True) As Currency
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    Dim curTotal As Currency
    Dim itmTeam As ListItem
    
    Screen.MousePointer = vbHourglass
    
    mlngGUID = lngGUID
    
    '获取客户姓名
    strSQL = "select YYRXM from SET_GRXX" _
            & " where GUID=" & mlngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        mstrYYRXM = rstemp("YYRXM")
        rstemp.Close
    End If
    Me.Caption = mstrYYRXM & "　的费用支付情况"
    
    '首先显示支付方式
    strSQL = "select ZFID,ZFMC from SET_ZFFS" _
            & " order by ZFMC"
    If LoadSETTABLE(cmbZFFS, strSQL) = False Then GoTo ExitLab
    '检查是否有可用的支付方式
    If cmbZFFS.ListCount < 1 Then
        MsgBox "当前尚未设置支付方式，您将无法使用收费功能！" & vbCrLf _
                & "您可以通过“系统设置”->“系统参数”进行设置，或者联系系统管理员！", _
                vbInformation, "提示"
    End If
    
    '显示收费历史记录
    '首先清空可能存在的记录
    lvwSFHistory.ListItems.Clear
    strSQL = "select SFID,SFRQ,ZFMC,SFFY" _
            & " from SET_SFMX_GR,SET_ZFFS" _
            & " where GUID=" & mlngGUID _
            & " and SET_SFMX_GR.ZFID=SET_ZFFS.ZFID"
    If LoadSETTABLE(lvwSFHistory, strSQL) = False Then GoTo ExitLab
    '加上合计
    If lvwSFHistory.ListItems.Count >= 1 Then
        For i = 1 To lvwSFHistory.ListItems.Count
            curTotal = curTotal + CCur(Val(lvwSFHistory.ListItems(i).SubItems(2)))
        Next i
        
        '借用itmTeam
        Set itmTeam = lvwSFHistory.ListItems.Add(, HEADER, "合计")
        itmTeam.SubItems(2) = CStr(curTotal)
    End If
    '调用单击事件
    lvwSFHistory_Click
    
    '如果有成交价格，则显示
    strSQL = "select XMJG,CJJG,PriceMemo from SET_GRXX" _
            & " where GUID=" & mlngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        lblTotalMoney.Caption = "总金额(元)：" & rstemp("XMJG") & ""
        txtYSTotal.Text = rstemp("CJJG") & ""
        txtPriceMemo.Text = rstemp("PriceMemo") & ""
    Else
        txtYSTotal.Text = ""
    End If
    cmdTotalSave.Enabled = False
    
    If Not blnEnablePrice Then
        Call EnablePriceInput(False)
    End If
    
    If Not blnEnableCharging Then
        Call EnableChargingInput(False)
    End If
    
    '显示自己
    Me.Show vbModal
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

Private Sub cmdUseMoneyCard_Click()
    Dim curConsume As Currency
    Dim strCardID As String
    
    '调用刷卡窗体
    curConsume = dlgUseMoneyCard.ShowMoneyCard(strCardID)
    Set dlgUseMoneyCard = Nothing
    
    '检查是否取消
    If curConsume <= 0 Then GoTo ExitLab
    
    '显示刷卡金额
    txtSShou.Text = CStr(curConsume)
    '记录卡号
    txtSShou.Tag = strCardID
    '禁止修改金额
    txtSShou.Enabled = False
    
    GoTo ExitLab
ExitLab:
    '
End Sub

Private Sub lvwSFHistory_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strZFSJ As String '支付时间
    Dim strSFID As String
    Dim i As Integer
    
    Me.MousePointer = vbHourglass
    
    txtSShou.Tag = "" '清除可能存在的卡号
    Call EnableMoneyInput(False)
    Call EnableMoneyCommand(False)
    cmdMoneyAdd.Enabled = True '启用添加
    '是否有选择
    If lvwSFHistory.SelectedItem Is Nothing Then
        ClearMoneyInput
        GoTo ExitLab
    End If
    
    '是否单击了合计行
    If lvwSFHistory.SelectedItem.Key = HEADER Then
        ClearMoneyInput
        GoTo ExitLab
    End If
    
    strSFID = Mid(lvwSFHistory.SelectedItem.Key, 2)
    strZFSJ = lvwSFHistory.SelectedItem.Text
    strSQL = "select *" _
            & " from SET_SFMX_GR" _
            & " where SFID='" & strSFID & "'" _
            & " and SFRQ='" & CDate(strZFSJ) & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        txtSShou.Text = rstemp("SFFY") & ""
        
        '收费方式
        For i = 0 To cmbZFFS.ListCount - 1
            If cmbZFFS.ItemData(i) = CLng(Val(rstemp("ZFID"))) Then
                cmbZFFS.ListIndex = i
                Exit For
            End If
        Next i
        '备注
        txtMemo.Text = rstemp("Memo") & ""
        
        Call EnableMoneyCommand(True)
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'清空收费信息
Private Sub ClearMoneyInput()
    txtSShou.Text = ""
    txtSShou.Tag = ""
    txtMemo.Text = ""
End Sub

'启用/禁用收费信息
Private Sub EnableMoneyInput(ByVal blnFlag As Boolean)
    txtSShou.Enabled = blnFlag
    cmbZFFS.Enabled = blnFlag
    txtMemo.Enabled = blnFlag
    cmdUseMoneyCard.Enabled = blnFlag
    
    lblSShou.Enabled = blnFlag
    lblZFFS.Enabled = blnFlag
    lblMemo.Enabled = blnFlag
End Sub

'启用/禁用收费命令按钮
Private Sub EnableMoneyCommand(ByVal blnFlag As Boolean, _
        Optional ByVal blnEdit As Boolean = False)
    cmdMoneyAdd.Enabled = blnFlag
    cmdMoneyModify.Enabled = blnFlag
    cmdMoneyDelete.Enabled = blnFlag
    cmdMoneySave.Enabled = blnFlag
    '如果为编辑模式，则启用保存按钮
    If blnEdit Then
        cmdMoneySave.Enabled = True
    Else
        cmdMoneySave.Enabled = False
    End If
End Sub

'启用/禁用计价按钮
Private Sub EnablePriceInput(ByVal blnFlag As Boolean)
    lblTotalMoney.Enabled = blnFlag
    cmdCalculate.Enabled = blnFlag
    lblYSTotal.Enabled = blnFlag
    txtYSTotal.Enabled = blnFlag
    cmdTotalSave.Enabled = blnFlag
    lblPriceMemo.Enabled = blnFlag
    txtPriceMemo.Locked = Not blnFlag
End Sub

'启用/禁用收费按钮
Private Sub EnableChargingInput(ByVal blnFlag As Boolean)
    lvwSFHistory.Enabled = blnFlag
    lblZFFS.Enabled = blnFlag
    cmbZFFS.Enabled = blnFlag
    lblSShou.Enabled = blnFlag
    txtSShou.Enabled = blnFlag
    cmdUseMoneyCard.Enabled = blnFlag
    lblMemo.Enabled = blnFlag
    txtMemo.Enabled = blnFlag
    cmdMoneyAdd.Enabled = blnFlag
    cmdMoneyModify.Enabled = blnFlag
    cmdMoneyDelete.Enabled = blnFlag
    cmdMoneySave.Enabled = blnFlag
End Sub

Private Sub txtPriceMemo_Change()
    cmdTotalSave.Enabled = True
End Sub

Private Sub txtSShou_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If txtSShou.Tag <> "" Then
        txtSShou.ToolTipText = "保存之后，才会从卡上减去消费金额"
    End If
End Sub

Private Sub txtYSTotal_Change()
    cmdTotalSave.Enabled = True
End Sub