frmtjrstj.frm

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

            Object.Width           =   2540
         EndProperty
         BeginProperty ColumnHeader(14) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
            SubItemIndex    =   13
            Text            =   "女55～64/已检/%"
            Object.Width           =   2540
         EndProperty
         BeginProperty ColumnHeader(15) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
            SubItemIndex    =   14
            Text            =   "男>=65/已检/%"
            Object.Width           =   2540
         EndProperty
         BeginProperty ColumnHeader(16) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
            SubItemIndex    =   15
            Text            =   "女>=65/已检/%"
            Object.Width           =   2540
         EndProperty
      End
   End
   Begin MSComctlLib.TreeView tvwXMu 
      Height          =   7410
      Left            =   180
      TabIndex        =   17
      Top             =   975
      Width           =   3150
      _ExtentX        =   5556
      _ExtentY        =   13070
      _Version        =   393217
      HideSelection   =   0   'False
      LabelEdit       =   1
      Style           =   7
      Appearance      =   1
   End
   Begin VB.Frame Frame1 
      BackColor       =   &H80000018&
      Caption         =   "散检人员人数统计结果"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   1125
      Left            =   180
      TabIndex        =   11
      Top             =   7290
      Visible         =   0   'False
      Width           =   11085
      Begin VB.Label lblSJRY 
         BackColor       =   &H80000018&
         Caption         =   "lblSJRY"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   9
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   780
         Left            =   420
         TabIndex        =   12
         Top             =   270
         Width           =   10560
      End
   End
End
Attribute VB_Name = "FrmTJRSTJ"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mblQuery As Boolean    '标识是否已查找过
Dim mdtmStart As Date
Dim mdtmEnd As Date
Dim m_blnShowInfo As Boolean

Private Sub cmdExit_Click()
    Unload Me
    
End Sub

Private Sub cmdPrint_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strTotalCount
    Dim strMaleCount
    Dim strFemaleCount
    Dim strTitle As String
    Dim intPage As Integer
    Dim sngTitleTop  As Single   '页面上边距
    Dim sngLineInterval As Single   '行间距
    Dim sngLeft, sngRight As Single '左、右页边距
    Dim sngCurrX, sngCurrY As Single      '当前打印机纵坐标
    Dim intLineCount As Integer     '当前页已打印的行数
    Dim i As Integer
    Dim intLinePerPage As Integer     '每页打印的行数
    
    intLinePerPage = 43
    
    '是否有打印数据
    If lvwRS.ListItems.Count < 1 Then
        MsgBox "没有打印内容。请通过设置查询条件，生成统计结果然后打印！", vbInformation, "提示"
        Exit Sub
    End If
    
'打印表头
    If DetectPrinter() = False Then
        MsgBox "您还未安装打印机", vbInformation, "提示"
        Exit Sub
    End If
    
    '初始为第一页
    intPage = 1
    
    '设成A4纸
    Printer.ScaleMode = vbMillimeters
    Printer.ScaleWidth = 210
    Printer.ScaleHeight = 297
    sngTitleTop = 25
    sngLeft = 15
    sngRight = 15
    sngLineInterval = 2
    
    GoSub PrintTitle
    GoSub PrintLine
        
    '首先进行查找
    If mblQuery = False Then
        cmdQuery_Click
    End If
    If mblQuery = True And lvwRS.ListItems.Count = 0 Then
        MsgBox "未查到符合条件的单位,请重新选择时间", vbInformation, "提示"
        Exit Sub
    End If
    
    '打表头，调整字体
    With Printer
        .FontName = "宋体"
        .FontSize = 9
        .FontBold = False
        .FontItalic = False
        .FontUnderline = False
    End With
    intLineCount = 1
    For i = 1 To lvwRS.ListItems.Count
        If intLineCount >= intLinePerPage Then
            intLineCount = 1
            Printer.NewPage
            intPage = intPage + 1
            GoSub PrintTitle
            GoSub PrintLine
            '调整字体
            With Printer
                .FontName = "宋体"
                .FontSize = 9
                .FontBold = False
                .FontItalic = False
                .FontUnderline = False
            End With
        End If
        Printer.CurrentX = sngCurrX
        Printer.CurrentY = sngCurrY
        If i < lvwRS.ListItems.Count Then
            Printer.Print "体检单位名称：" & lvwRS.ListItems(i)
        Else
            Printer.Print lvwRS.ListItems(i)
        End If
        sngCurrY = sngCurrY + Printer.TextHeight("高度") + sngLineInterval
        intLineCount = intLineCount + 1
        
        If intLineCount >= intLinePerPage Then
            intLineCount = 1
            Printer.NewPage
            intPage = intPage + 1
            GoSub PrintTitle
            GoSub PrintLine
            '调整字体
            With Printer
                .FontName = "宋体"
                .FontSize = 9
                .FontBold = False
                .FontItalic = False
                .FontUnderline = False
            End With
        End If
        Printer.CurrentX = sngCurrX
        Printer.CurrentY = sngCurrY
        strTotalCount = Split(lvwRS.ListItems(i).SubItems(1), "/")
        strMaleCount = Split(lvwRS.ListItems(i).SubItems(2), "/")
        strFemaleCount = Split(lvwRS.ListItems(i).SubItems(3), "/")
        Printer.Print "总人数 " & strTotalCount(0) _
                & " 人, 其中男性 " & strMaleCount(0) & " 人，女性 " _
                & strFemaleCount(0) & " 人；"
        sngCurrY = sngCurrY + Printer.TextHeight("高度") + sngLineInterval
        intLineCount = intLineCount + 1
        
        If intLineCount >= intLinePerPage Then
            intLineCount = 1
            Printer.NewPage
            intPage = intPage + 1
            GoSub PrintTitle
            GoSub PrintLine
             '调整字体
            With Printer
                .FontName = "宋体"
                .FontSize = 9
                .FontBold = False
                .FontItalic = False
                .FontUnderline = False
            End With
       End If
        Printer.CurrentX = sngCurrX
        Printer.CurrentY = sngCurrY
        Printer.Print "已体检人数 " & strTotalCount(1) _
                & " 人, 占总人数的百分比：" & strTotalCount(2) _
                & "，其中男性 " & strMaleCount(1) & " 人，女性 " _
                & strFemaleCount(1) & " 人。"
        sngCurrY = sngCurrY + Printer.TextHeight("高度") + sngLineInterval
        intLineCount = intLineCount + 1
        
        sngCurrY = sngCurrY + Printer.TextHeight("高度") + sngLineInterval
        intLineCount = intLineCount + 1
        
    Next i
    
    Printer.EndDoc
   
    Exit Sub
   
PrintLine:
    Printer.DrawWidth = 8
    Printer.DrawStyle = 2
    Printer.Line (sngLeft + 5, sngCurrY + sngLineInterval)-(sngLeft + 173, sngCurrY + sngLineInterval)
    sngCurrY = sngCurrY + 5

    Return
    
PrintTitle:
    '打印表头
    With Printer
        .FontName = "宋体"
        .FontSize = 15
        .FontBold = True
        .FontItalic = False
        .FontUnderline = False
        
        .CurrentY = sngTitleTop
        If intPage = 1 Then
            If optTTi.Value Then
                strTitle = "体检人数统计结果"
            Else
                strTitle = lvwRS.Tag & "  的体检人数统计结果"
            End If
            .CurrentX = (.ScaleWidth - .TextWidth(strTitle)) / 2
            Printer.Print strTitle
        Else
            If optTTi.Value Then
                strTitle = "体检人数统计结果(续表)"
            Else
                strTitle = lvwRS.Tag & "  的体检人数统计结果(续表)"
            End If
            .CurrentX = (.ScaleWidth - .TextWidth(strTitle)) / 2
            Printer.Print strTitle
        End If
    End With
    sngCurrY = sngTitleTop + Printer.TextHeight("高度") + sngLineInterval
    sngCurrX = sngLeft + 10
    Return
    
    
    GoTo ExitLab
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 dtmStart As Date
    Dim dtmEnd As Date
    Dim nodTemp As Node
    Dim rstemp As ADODB.Recordset
    Dim rsFZ As ADODB.Recordset
    Dim rsNum As ADODB.Recordset
    Dim strSQL As String
    Dim intSJZRS, intSJNXZRS, intSJYDJRS, intSJYDJNXRS As Integer
    Dim i, intTJDWS As Integer
    Dim itemX As ListItem
    Dim strDWMC As String
    Dim strBFB As String
    Dim intTTZRS, intTTMaleZRS, intTTFemaleZRS, intTTYJRS, intTTYJMaleRS, intTTYJFemaleRS As Integer
    Dim blnHave As Boolean
    Dim strXMID As String
    
    Me.MousePointer = vbHourglass
    mblQuery = True