dlgpaymoney.frm

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

            ScrollBars      =   2  'Vertical
            TabIndex        =   27
            Top             =   960
            Width           =   2715
         End
         Begin VB.TextBox txtYSTotal 
            Alignment       =   2  'Center
            ForeColor       =   &H00FF0000&
            Height          =   285
            Left            =   1470
            TabIndex        =   3
            Top             =   570
            Width           =   1275
         End
         Begin XPControls.XPCommandButton cmdCalculate 
            Height          =   315
            Left            =   2880
            TabIndex        =   2
            Top             =   180
            Width           =   585
            _ExtentX        =   1032
            _ExtentY        =   556
            Caption         =   "计算"
            BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
               Name            =   "MS Sans Serif"
               Size            =   8.25
               Charset         =   0
               Weight          =   400
               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
         End
         Begin XPControls.XPCommandButton cmdTotalSave 
            Height          =   315
            Left            =   2880
            TabIndex        =   4
            Top             =   540
            Width           =   585
            _ExtentX        =   1032
            _ExtentY        =   556
            Caption         =   "保存"
            BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
               Name            =   "MS Sans Serif"
               Size            =   8.25
               Charset         =   0
               Weight          =   400
               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
         End
         Begin VB.Label lblPriceMemo 
            Alignment       =   1  'Right Justify
            BackStyle       =   0  'Transparent
            Caption         =   "备注："
            Height          =   255
            Left            =   420
            TabIndex        =   28
            Top             =   960
            Width           =   915
         End
         Begin VB.Label lblYSTotal 
            BackStyle       =   0  'Transparent
            Caption         =   "成交价格(元)："
            Height          =   255
            Left            =   180
            TabIndex        =   6
            Top             =   600
            Width           =   1215
         End
         Begin VB.Label lblTotalMoney 
            AutoSize        =   -1  'True
            BackStyle       =   0  'Transparent
            Caption         =   "总金额(元)："
            Height          =   195
            Left            =   360
            TabIndex        =   5
            Top             =   240
            Width           =   960
         End
      End
      Begin VB.Line Line1 
         BorderColor     =   &H00FF0000&
         BorderWidth     =   2
         X1              =   3150
         X2              =   7740
         Y1              =   2010
         Y2              =   2025
      End
   End
End
Attribute VB_Name = "dlgPayMoney"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mcurCurrentMoney As Currency
Dim menuOperation_SF As OperationType
Dim mlngGUID As Long
Dim mstrYYRXM As String

Private Sub cmdCalculate_Click()
    Dim curTotal As Currency
    
    curTotal = GetTotalMoney_GR(mlngGUID)
    lblTotalMoney.Caption = "总金额(元)：" & curTotal
    txtYSTotal.Text = Trim(txtYSTotal.Text)
    If txtYSTotal.Text = "" Then
        txtYSTotal.Text = curTotal
    End If
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdMoneyAdd_Click()
    menuOperation_SF = Add
    Call ClearMoneyInput
    Call EnableMoneyInput(True)
    Call EnableMoneyCommand(False, True)
    txtSShou.SetFocus
End Sub

Private Sub cmdMoneyDelete_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strSFID As String '收费编号
    
    Me.MousePointer = vbHourglass
    '是否有选择
    If lvwSFHistory.SelectedItem Is Nothing Then GoTo ExitLab
    
    '确认删除
    If MsgBox("该操作不可恢复！" & vbCrLf & "您确认要删除客户 " _
            & mstrYYRXM & " 的支付时间为 " _
            & lvwSFHistory.SelectedItem.Text & " 的支付记录吗？", _
            vbExclamation + vbYesNo + vbDefaultButton2, "小心") = vbNo Then GoTo ExitLab
    
    '记录收费编号
    strSFID = Mid(lvwSFHistory.SelectedItem.Key, 2)
    '构造删除语句
    strSQL = "delete from SET_SFMX_GR" _
            & " where SFID='" & strSFID & "'"
    GCon.Execute strSQL
    
    '首先从合计中去除
    With lvwSFHistory
        .ListItems(.ListItems.Count).SubItems(2) = CStr(CCur(Val(.ListItems(.ListItems.Count).SubItems(2)) - Val(.SelectedItem.SubItems(2))))
    End With
    '从左侧列表中删除
    Call DeleteItemFromListView(lvwSFHistory, lvwSFHistory.SelectedItem.Index)
    If lvwSFHistory.ListItems.Count = 1 Then
        '说明只有一条合计行，需要删除
        Call DeleteItemFromListView(lvwSFHistory, 1)
    End If
    lvwSFHistory_Click
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdMoneyModify_Click()
    menuOperation_SF = Modify
    Call EnableMoneyInput(True)
    Call EnableMoneyCommand(False, True)
    txtSShou.SetFocus
End Sub

Private Sub cmdMoneySave_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strSFID As String '收费编号
    Dim strZFID As String '支付方式的编号
    Dim lngGUID As String '预约ID
    Dim itmTemp As ListItem
    Dim dtmNow As Date
    Dim i As Integer
    Dim curTotal As Currency
    Dim curConsume As Currency
    Dim strCardID As String
    Dim blnUnitPay As Boolean '当前支付方式与团体支付是否关联
    
    Me.MousePointer = vbHourglass
    
    '是否选择了支付方式
    If cmbZFFS.ListIndex < 0 Then
        MsgBox "请选择支付方式！", vbInformation, "提示"
        cmbZFFS.SetFocus
        GoTo ExitLab
    Else
        strZFID = LongToString(cmbZFFS.ItemData(cmbZFFS.ListIndex), LENGTHOFZFID)
    End If
    
    '实收
    curConsume = CCur(Val(txtSShou.Text))
    txtSShou.Text = CStr(curConsume)
    
    '是否大于零
    If curConsume < 0 Then
        MsgBox "实收金额不能小于零！", vbInformation, "提示"
        txtSShou.SetFocus
        GoTo ExitLab
    End If
    
    '是否团体支付
    strSQL = "select UnitPay from SET_ZFFS" _
            & " where ZFID='" & strZFID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    blnUnitPay = rstemp("UnitPay")
    rstemp.Close
    
    '散客不能使用团体支付
    If blnUnitPay Then
        strSQL = "select isnull(YYID,'') from SET_GRXX" _
                & " where GUID=" & mlngGUID
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If rstemp(0) = "" Then
            MsgBox "当前客户不属于团体客户，不能使用与团体支付建立了关联的支付方式！", vbExclamation, "提示"
            GoTo ExitLab
        End If
        rstemp.Close
    End If
    
    '总金额是否超过了应付金额
    If lvwSFHistory.ListItems.Count > 1 Then
        curTotal = CCur(Val(lvwSFHistory.ListItems(lvwSFHistory.ListItems.Count).SubItems(2)))
    End If
    curTotal = curTotal + CCur(Val(txtSShou.Text))
    '检索成交价格
    strSQL = "select isnull(CJJG,0) from SET_GRXX" _
            & " where GUID=" & mlngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rstemp(0) < curTotal Then
        MsgBox "您输入的收费金额，已经超过了成交价格，请仔细核查！", vbExclamation, "提示"
        txtSShou.SetFocus
        GoTo ExitLab
    End If
    rstemp.Close
    
    '是否刷卡
    If txtSShou.Tag <> "" Then
        strCardID = txtSShou.Tag
        '检查卡号余额是否足够
        strSQL = "select CardBalance from SET_MONEYCARD" _
                & " where CardID='" & strCardID & "'"
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If curConsume > rstemp("CardBalance") Then
            MsgBox "卡号 “" & strCardID & "” 上的余额已不足以完成此次支付，请重新设置消费金额！", _
                    vbExclamation, "提示"
            GoTo ExitLab
        End If
    End If
    
    '在事务中处理
    GCon.BeginTrans
    On Error GoTo RollBack
    dtmNow = Now
    If strCardID <> "" Then
        '写入消费记录
        If CardConsume(strCardID, False, curConsume, dtmNow, "支出") = False Then GoTo RollBack
        
        '从代金卡上减去消费金额
        strSQL = "update SET_MONEYCARD set" _
                & " CardBalance=CardBalance-" & curConsume _
                & " where CardID='" & strCardID & "'"
        GCon.Execute strSQL
    End If
    
    If menuOperation_SF = Add Then
        strSFID = GetMaxID("SET_SFMX_GR", "SFID", LongToString(1, LENGTHOFSFID), True)
    Else
        strSFID = Mid(lvwSFHistory.SelectedItem.Key, 2)
    End If
    
    '更新记录
    strSQL = "update SET_SFMX_GR set" _
            & " GUID=" & mlngGUID _
            & ",SFFY=" & curConsume _
            & ",ZFID='" & strZFID & "'" _
            & ",Memo='" & txtMemo.Text & "'" _
            & ",UnitPay=" & IIf(blnUnitPay, 1, 0)
    If menuOperation_SF = Add Then
        strSQL = strSQL & ",SFRQ='" & dtmNow & "'"
    End If
    strSQL = strSQL & " where SFID='" & strSFID & "'"
    GCon.Execute strSQL
    '提交事务
    GCon.CommitTrans
    On Error GoTo ErrMsg
    
    '相应修改左侧列表
    With lvwSFHistory
        If menuOperation_SF = Add Then
            '添加的时候
            '如果原来有合计，则删除合计
            If .ListItems.Count >= 1 Then
                .ListItems.Remove .ListItems.Count
            End If
            '添加新记录
            Set itmTemp = .ListItems.Add(, HEADER & strSFID, dtmNow)
            '重新添加合计
            .ListItems.Add , HEADER, "合计"