frmdwtjfy.frm

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

    PrintFYQD_DW Mid(lvwDW.SelectedItem.Key, 2)
    
    Exit Sub
Print_Cancel:
    MousePointer = vbDefault
    If Err.Number <> cdlCancel Then
        Status = SetError(Err.Number, "无法完成打印，请确认打印机电源已经开启并与计算机正确连接！:" _
                & vbCrLf & Err.Description, Err.Source)
        ErrMsg Status
    End If
End Sub

'打印当前选择用户的费用清单
Public Sub PrintFYQD_DW(ByVal strYYID As String)
On Error Resume Next
    Dim strHealthID As String '当前选中客户
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    Dim strName As String
    Dim strSex As String
    Dim strTJRQ As String
    Dim curTotal As Currency
    Dim blnTC As Boolean '是否选择了套餐
    Dim lngTCID As Long '套餐ID
    Dim strTCMC As String '套餐名称
    Dim curTCJG As Currency '套餐价格
    Dim curOtherXMu As Currency '加项价格
    Dim sngZheKou As Single '折扣
    Dim curTemp As Currency
    Dim intTCID As Integer
    Dim rsFY As ADODB.Recordset
    Dim lngGUID As Long
    Dim curTCanTotal As Currency '套餐合计
    Dim curOtherTotal As Currency '加项合计
    Dim strReportTitle As String
    
    Dim intPage As Integer
    Dim sngCurrY As Single
    Dim intCurrLine As Integer
    
    Dim sngTitleTop As Single
    Dim sngHospitalTop As Single
    
    Dim sngUnitTop As Single
    Dim sngTextLeft As Single
    Dim sngNameLeft As Single '性命
    Dim sngSexLeft As Single '性别
    Dim sngAgeLeft As Single '套餐
    Dim sngJGeLeft As Single '套餐价格
    Dim sngOtherJGeLeft As Single '加项价格
    Dim sngUnitPaylLeft As Single '每个客户的合计
    Dim sngHeaderTop As Single
    Dim sngTextTop As Single
    Dim sngTextBottom As Single
    Dim sngPageNumberTop As Single
    
    Me.MousePointer = vbHourglass
    
    sngTitleTop = 25
    sngHospitalTop = 34
    sngUnitTop = 42
    sngTextLeft = 30
    sngNameLeft = sngTextLeft
    sngSexLeft = sngTextLeft + 23
    sngAgeLeft = sngTextLeft + 38
    sngJGeLeft = sngTextLeft + 70
    sngOtherJGeLeft = sngTextLeft + 95
    sngUnitPaylLeft = sngTextLeft + 130
    sngHeaderTop = 52
    sngTextTop = 59
    sngTextBottom = 272
    sngPageNumberTop = 285
    
    If TxtZKL.Text <> "" Then
        sngZheKou = TxtZKL.Text
    Else
        sngZheKou = 1
    End If
    
    curTotal = 0
    
    intPage = 1 '从第一页开始
    '打印第一页的标题
    GoSub PrintTitle
    
    With Printer
        '打印报表正文
        '循环打印所有记录
        intCurrLine = 1
        
        If LvwFYMX.ListItems.Count >= 1 Then
            For i = 1 To LvwFYMX.ListItems.Count
                .FontSize = 9
                .FontBold = False
                '计算纵坐标
                sngCurrY = sngTextTop + (intCurrLine - 1) * .TextHeight("高度") * 1.5
                If sngCurrY > sngTextBottom Then '该分页
                    Printer.NewPage
                    intPage = intPage + 1
                    GoSub PrintTitle
                    
                    intCurrLine = 1
                    .FontSize = 9
                    .FontBold = False
                    '分页后重新计算纵坐标
                    sngCurrY = sngTextTop + (intCurrLine - 1) * .TextHeight("高度") * 1.5
                End If
                '姓名
                .CurrentX = sngNameLeft
                .CurrentY = sngCurrY
                Printer.Print LvwFYMX.ListItems(i).Text 'rsTemp("姓名")
                
                '性别
                .CurrentX = sngSexLeft
                .CurrentY = sngCurrY
                Printer.Print LvwFYMX.ListItems(i).SubItems(1) 'rsTemp("性别")
                
                '年龄
                .CurrentX = sngAgeLeft
                .CurrentY = sngCurrY
                Printer.Print LvwFYMX.ListItems(i).SubItems(2)
                
                '加项费用
                .CurrentX = sngOtherJGeLeft
                .CurrentY = sngCurrY
                Printer.Print LvwFYMX.ListItems(i).SubItems(3)
                
                '其中团体支付
                .CurrentX = sngUnitPaylLeft
                .CurrentY = sngCurrY
                Printer.Print LvwFYMX.ListItems(i).SubItems(4)
                
                intCurrLine = intCurrLine + 1
            Next
        End If
        
        '打印合计行
        '在最后一页上打印合计
        .FontSize = 9
        .FontBold = True
        sngCurrY = sngTextTop + (intCurrLine - 1) * .TextHeight("高度") * 1.5 + 5
        Printer.Line (sngTextLeft - 5, sngCurrY - 1.5)-(sngTextLeft + sngUnitPaylLeft + 2, sngCurrY - 1.5)
        .CurrentX = sngTextLeft
        .CurrentY = sngCurrY
        Printer.Print "总计：应付费用：" & m_strTotal_Need & "元   已付费用：" & m_strTotal_Payed _
                & "元   未付费用：" & m_strTotal_Lost & "元"
        
'        .CurrentX = sngTextLeft + 15
'        .CurrentY = sngCurrY
'        Printer.Print "套餐价格：" & curTCanTotal
'
'        .CurrentX = sngTextLeft + 45
'        .CurrentY = sngCurrY
'        Printer.Print "折扣率：" & sngZheKou
'
'        .CurrentX = sngTextLeft + 70
'        .CurrentY = sngCurrY
'        Printer.Print "加项费用：" & curOtherTotal
'
'        .CurrentX = sngTextLeft + 110
'        .CurrentY = sngCurrY
        
        '为每个客户提交一次打印
        Printer.EndDoc
    End With
    GoTo ExitLab

'打印报表标题
PrintTitle:
    With Printer
        '打印标题
        .FontName = "宋体"
        .FontSize = 17
        .FontBold = True
        .FontItalic = False
        .FontUnderline = False
        
        If intPage = 1 Then
            strReportTitle = "单位体检费用清单"
        Else
            strReportTitle = "单位体检费用清单(续表)"
        End If
        .CurrentX = (Printer.ScaleWidth - .TextWidth(strReportTitle)) / 2
        .CurrentY = sngTitleTop
        Printer.Print strReportTitle
        
        '打印单位
        .FontSize = 11
        .CurrentX = (Printer.ScaleWidth - .TextWidth(gstrHospital)) / 2
        .CurrentY = sngHospitalTop
        Printer.Print gstrHospital
        
        '打印团体信息
        .FontSize = 9
        .CurrentX = sngTextLeft - 5
        .CurrentY = sngUnitTop
        Printer.Print "单位名称：" & lvwDW.SelectedItem.Text
        
        .CurrentX = sngTextLeft + 95
        .CurrentY = sngUnitTop
        Printer.Print "总人数：" & LvwFYMX.ListItems.Count - 1
        
        .CurrentX = sngTextLeft + 125
        .CurrentY = sngUnitTop
        Printer.Print "打印日期：" & CStr(Date)
        
        '打印报表题头
        Printer.DrawWidth = 5
        Printer.Line (sngTextLeft - 5, sngHeaderTop - 1.5)-(sngTextLeft + sngUnitPaylLeft + 2, sngHeaderTop - 1.5)
        
        .CurrentX = sngNameLeft
        .CurrentY = sngHeaderTop
        Printer.Print "姓名"
        
        .CurrentX = sngSexLeft
        .CurrentY = sngHeaderTop
        Printer.Print "性别"
        
        .CurrentX = sngAgeLeft
        .CurrentY = sngHeaderTop
        Printer.Print "年龄"
        
        .CurrentX = sngOtherJGeLeft
        .CurrentY = sngHeaderTop
        Printer.Print "加项费用(元)"
        
        .CurrentX = sngUnitPaylLeft
        .CurrentY = sngHeaderTop
        Printer.Print "其中团体支付(元)"
        
        Printer.Line (sngTextLeft - 5, sngHeaderTop + .TextHeight("高度") + 1)-(sngTextLeft + sngUnitPaylLeft + 2, sngHeaderTop + .TextHeight("高度") + 1)
    
        .CurrentX = (Printer.ScaleWidth - .TextWidth(str(intPage))) / 2
        .CurrentY = sngPageNumberTop
        Printer.Print intPage
    End With
    Return
    
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub lvwDW_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim itmFYMX As ListItem
    Dim strYYID As String
    Dim lngGUID As Long
    Dim rsFY As ADODB.Recordset
    Dim intTCID As Integer
    Dim curTotal_Person As Currency
    Dim curTotal_UnitPay As Currency
    
    Me.MousePointer = vbHourglass
    
    If lvwDW.SelectedItem Is Nothing Then GoTo ExitLab
    
    '记录团检预约编号
    strYYID = Mid(lvwDW.SelectedItem.Key, 2)
    
    '首先清除费用明细
    LvwFYMX.ListItems.Clear
    
    '提取当前团体的人员
    strSQL = "select GUID,YYRXM as 姓名,Sex as 性别,Age as 年龄" _
            & " from SET_GRXX" _
            & " where SET_GRXX.YYID='" & strYYID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount > 0 Then
        cmdPrint.Enabled = True
        rstemp.MoveFirst
        Do While Not rstemp.EOF
            Set itmFYMX = LvwFYMX.ListItems.Add(, "W" & rstemp("GUID"), rstemp("姓名"))
            itmFYMX.SubItems(1) = rstemp("性别")
            itmFYMX.SubItems(2) = rstemp("年龄") & ""
            
            lngGUID = rstemp("GUID")
            
            '加项费用
            strSQL = "select CJJG from SET_GRXX" _
                    & " where GUID=" & lngGUID
            Set rsFY = New ADODB.Recordset
            rsFY.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
            If Not IsNull(rsFY(0)) Then
                itmFYMX.SubItems(3) = rsFY(0)
            Else
                itmFYMX.SubItems(3) = GetTotalMoney_GR(lngGUID)
            End If
            rsFY.Close
            curTotal_Person = curTotal_Person + CCur(Val(itmFYMX.SubItems(3)))
            
            '获取团体支付费用
            strSQL = "select isnull(Sum(SFFY),0) from SET_SFMX_GR" _
                    & " where GUID=" & lngGUID _
                    & " and UnitPay=1"
            Set rsFY = New ADODB.Recordset
            rsFY.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
            itmFYMX.SubItems(4) = CStr(rsFY(0))
            curTotal_UnitPay = curTotal_UnitPay + rsFY(0)
            rsFY.Close
            
            rstemp.MoveNext
        Loop
        rstemp.Close
        
        Set itmFYMX = LvwFYMX.ListItems.Add(, "W", "合计")
        itmFYMX.SubItems(3) = curTotal_Person
        itmFYMX.SubItems(4) = curTotal_UnitPay
        itmFYMX.ForeColor = vbBlue
    End If
    
    '团体应付费用
    strSQL = "select isnull(CJJG,0) from YY_TJDJ" _
            & " where YYID='" & strYYID & "'"
    Set rsFY = New ADODB.Recordset
    rsFY.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    m_strTotal_Need = CStr(rsFY(0)) & "+" _
            & CStr(curTotal_UnitPay) & "(个人加项)=" _
            & CStr(rsFY(0) + curTotal_UnitPay)
    lblMemo.Caption = "当前团体应付总费用(元)：" & m_strTotal_Need
    m_strTotal_Lost = CStr(rsFY(0) + curTotal_UnitPay)
    rsFY.Close
    
    '团体已付费用
    strSQL = "select isnull(Sum(SFFY),0) from SET_SFMX" _
            & " where YYID='" & strYYID & "'"
    Set rsFY = New ADODB.Recordset
    rsFY.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    m_strTotal_Payed = CStr(rsFY(0))
    m_strTotal_Lost = CStr(CCur(Val(m_strTotal_Lost)) - rsFY(0))
    lblMemo.Caption = lblMemo.Caption & vbCrLf & "已付费用：" & m_strTotal_Payed
    rsFY.Close
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub LvwDW_KeyUp(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyUp, vbKeyDown
            lvwDW_Click
        Case Else
            '
    End Select
End Sub

Private Sub TxtFY_Change()
    If Len(TxtFY.Text) > 0 Then
        TxtZKL.Locked = True
    Else
        TxtZKL.Locked = False
    End If

End Sub

Private Sub TxtFY_KeyPress(KeyAscii As Integer)
    TxtZKL.Text = ""
    If (KeyAscii <> vbKeyBack) And (KeyAscii <> vbKeyReturn) And KeyAscii <> 46 Then
        '是否输入了数字
        If (KeyAscii < vbKey0) Or (KeyAscii > vbKey9) Then
            Beep 50, 10
            KeyAscii = 0
        End If
        
        '校验长度
        If Len(TxtFY.Text) >= 7 Then
            MsgBox "您输入的数字太长！", vbInformation, "提示"
            KeyAscii = 0
            Exit Sub
        End If
    ElseIf KeyAscii = 46 Then
        If InStr(1, Mid(TxtFY.Text, 1, Len(TxtFY.Text) - 1), ".", vbTextCompare) > 0 Then '说明止一个"."
            Beep 50, 10
            KeyAscii = 0
            Exit Sub
        End If
    End If

End Sub

Private Sub TxtZKL_Change()
    If Len(TxtZKL.Text) > 0 Then
        TxtFY.Locked = True
    Else
        TxtFY.Locked = False
    End If
End Sub

Private Sub TxtZKL_KeyPress(KeyAscii As Integer)
    TxtFY.Text = ""
    If (KeyAscii <> vbKeyBack) And (KeyAscii <> vbKeyReturn) And KeyAscii <> 46 Then
        '是否输入了数字
        If (KeyAscii < vbKey0) Or (KeyAscii > vbKey9) Then
            Beep 50, 10
            KeyAscii = 0
        End If
        
        '校验长度
        If Len(TxtZKL.Text) >= 5 Then
            MsgBox "您输入的数字太长！", vbInformation, "提示"
            KeyAscii = 0
            Exit Sub
        End If
    ElseIf KeyAscii = 46 Then
        If InStr(1, Mid(TxtZKL.Text, 1, Len(TxtZKL.Text) - 1), ".", vbTextCompare) > 0 Then '说明止一个"."
            Beep 50, 10
            KeyAscii = 0
            Exit Sub
        End If
    End If

End Sub