frmgreport.frm

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

                    ByVal lngFontSize As Long, _
                    ByVal lngFontStyle As Long, _
                    ByVal FontName As String, _
                    ByVal lngFrontColor As Long, _
                    ByVal lngBackColor As Long, _
                    ByVal lngRowHeight As Long)
    Cell1.DoAppendRow 1
    Cell1.DoSetCellString 0, Cell1.Rows - 1, strKSTitle
    Cell1.DoJoinCells 0, Cell1.Rows - 1, 4, Cell1.Rows - 1
    If Cell1.Rows = 1 Then
        Cell1.DoDrawLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 1, lngLine, lngColor
    Else
        Cell1.DoDrawLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 2, lngLine, lngColor
        Cell1.DoDrawLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 3, lngLine, lngColor
        Cell1.DoDrawLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 5, lngLine, lngColor
    End If
    Cell1.DoSetCellFont 0, Cell1.Rows - 1, lngFontSize, lngFontStyle, lngFontName
    Cell1.DoSetCellColor 0, Cell1.Rows - 1, lngFrontColor, lngBackColor
    Cell1.DoSetRowHeight Cell1.Rows - 1, lngRowHeight
    
    'Cell1.DoRedrawAll
End Sub



Private Sub AddOther(ByVal strKSTitle As String, _
                    ByVal lngLine As Long, _
                    ByVal lngColor As Long, _
                    ByVal lngFontSize As Long, _
                    ByVal lngFontStyle As Long, _
                    ByVal FontName As String, _
                    ByVal lngFrontColor As Long, _
                    ByVal lngBackColor As Long, _
                    ByVal lngRowHeight As Long)
    Cell1.DoAppendRow 1
    Cell1.DoSetCellString 0, Cell1.Rows - 1, strKSTitle
    Cell1.DoJoinCells 0, Cell1.Rows - 1, 4, Cell1.Rows - 1

    Cell1.DoDrawLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 5, lngLine, lngColor


    Cell1.DoSetCellFont 0, Cell1.Rows - 1, lngFontSize, lngFontStyle, lngFontName
    Cell1.DoSetCellColor 0, Cell1.Rows - 1, lngFrontColor, lngBackColor
    Cell1.DoSetRowHeight Cell1.Rows - 1, lngRowHeight
    Cell1.DoSetCellAlignment 0, Cell1.Rows - 1, 36
    'Cell1.DoRedrawAll
End Sub

'添加大项
Private Sub AddDX(ByVal strDXTitle As String, _
                    ByVal strDXTime As String, _
                    ByVal strDXDocName As String, _
                    ByVal lngLine As Long, _
                    ByVal lngColor As Long, _
                    ByVal lngFontSize As Long, _
                    ByVal lngFontStyle As Long, _
                    ByVal FontName As String, _
                    ByVal lngFrontColor As Long, _
                    ByVal lngBackColor As Long)
    Dim i As Integer
    Cell1.DoAppendRow 1
    Cell1.DoSetCellString 0, Cell1.Rows - 1, strDXTitle   '大项名称
    Cell1.DoSetCellString 1, Cell1.Rows - 1, "检查时间："
    Cell1.DoSetCellString 2, Cell1.Rows - 1, strDXTime
    Cell1.DoSetCellString 3, Cell1.Rows - 1, "检查医生："
    Cell1.DoSetCellString 4, Cell1.Rows - 1, strDXDocName
    If Cell1.Rows = 1 Then
        Cell1.DoDrawLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 1, lngLine, lngColor
    Else
        For i = 0 To 4
            Cell1.DoDrawLine i, Cell1.Rows - 1, 4, Cell1.Rows - 1, 2, lngLine, lngColor
            If i = 4 Then
                Cell1.DoDrawLine i, Cell1.Rows - 1, 4, Cell1.Rows - 1, 3, lngLine, lngColor
            End If
            Cell1.DoDrawLine i, Cell1.Rows - 1, 4, Cell1.Rows - 1, 5, lngLine, lngColor
            Cell1.DoSetCellAlignment i, Cell1.Rows - 1, 4
        Next
    End If
    For i = 0 To 4
        Cell1.DoSetCellFont i, Cell1.Rows - 1, lngFontSize, lngFontStyle, lngFontName
        Cell1.DoSetCellColor i, Cell1.Rows - 1, lngFrontColor, lngBackColor
    Next
    'Cell1.DoRedrawAll
End Sub
'添加小项
Private Sub AddXX(ByVal strCell0 As String, _
                    ByVal strCell1 As String, _
                    ByVal strCell2 As String, _
                    ByVal strCell3 As String, _
                    ByVal strCell4 As String, _
                    ByVal lngLine As Long, _
                    ByVal lngColor As Long, _
                    ByVal lngFontSize As Long, _
                    ByVal lngFontStyle As Long, _
                    ByVal FontName As String, _
                    ByVal lngErrColor As Long, _
                    ByVal lngErr As Long)
    Dim i As Integer
    Cell1.DoAppendRow 1
    Cell1.DoSetCellString 0, Cell1.Rows - 1, strCell0
    Cell1.DoSetCellString 1, Cell1.Rows - 1, strCell1
    Cell1.DoSetCellString 2, Cell1.Rows - 1, strCell2
    Cell1.DoSetCellString 3, Cell1.Rows - 1, strCell3
    Cell1.DoSetCellString 4, Cell1.Rows - 1, strCell4
    If Cell1.Rows = 1 Then
        Cell1.DoDrawLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 1, lngLine, lngColor
    Else
        For i = 0 To 4
            Cell1.DoDrawLine i, Cell1.Rows - 1, 4, Cell1.Rows - 1, 2, lngLine, lngColor
            If i = 4 Then
                Cell1.DoDrawLine i, Cell1.Rows - 1, 4, Cell1.Rows - 1, 3, lngLine, lngColor
            End If
            Cell1.DoDrawLine i, Cell1.Rows - 1, 4, Cell1.Rows - 1, 5, lngLine, lngColor
            Cell1.DoSetCellAlignment i, Cell1.Rows - 1, 4
        Next
    End If
    For i = 0 To 4
        Cell1.DoSetCellFont i, Cell1.Rows - 1, lngFontSize, lngFontStyle, lngFontName
    Next
    If lngErr > 0 Then Cell1.DoSetCellColor 1, Cell1.Rows - 1, lngErrColor, &H80000005
    'Cell1.DoRedrawAll
End Sub


'添加科室小结/总检结论/总检建议
Private Sub AddKSXJ(ByVal strLbl As String, _
                    ByVal strCell As String, _
                    ByVal lngLine As Long, _
                    ByVal lngColor As Long, _
                    ByVal lngFontSize As Long, _
                    ByVal lngFontStyle As Long, _
                    ByVal FontName As String, _
                    ByVal lngFrontColor As Long, _
                    ByVal lngBackColor As Long)

    Cell1.DoAppendRow 1
    Cell1.DoSetCellString 0, Cell1.Rows - 1, strLbl
    Cell1.DoSetCellString 1, Cell1.Rows - 1, strCell
    Cell1.DoJoinCells 1, Cell1.Rows - 1, 4, Cell1.Rows - 1
    If Cell1.Rows = 1 Then
        Cell1.DoDrawLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 1, lngLine, lngColor
    Else
        Cell1.DoDrawLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 2, lngLine, lngColor
        Cell1.DoDrawLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 3, lngLine, lngColor
        Cell1.DoDrawLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 5, lngLine, lngColor
        
        Cell1.DoDrawLine 1, Cell1.Rows - 1, 4, Cell1.Rows - 1, 2, lngLine, lngColor
        Cell1.DoDrawLine 1, Cell1.Rows - 1, 4, Cell1.Rows - 1, 3, lngLine, lngColor
        Cell1.DoDrawLine 1, Cell1.Rows - 1, 4, Cell1.Rows - 1, 5, lngLine, lngColor

        Cell1.DoSetCellAlignment 0, Cell1.Rows - 1, 12
    End If
    Cell1.DoSetCellFont 0, Cell1.Rows - 1, lngFontSize, lngFontStyle, lngFontName
    Cell1.DoSetCellFont 1, Cell1.Rows - 1, lngFontSize, lngFontStyle, lngFontName

    Cell1.DoSetCellColor 0, Cell1.Rows - 1, lngFrontColor, lngBackColor
    Cell1.DoSetCellColor 1, Cell1.Rows - 1, lngFrontColor, lngBackColor
    Cell1.DoSetCellTextStyle 1, Cell1.Rows - 1, 1
    Cell1.DoSetRowHeight Cell1.Rows - 1, Cell1.DoGetRowBestHeight(Cell1.Rows - 1)

    'Cell1.DoRedrawAll
End Sub
'''Public Function ShowInfo(ByVal strSQL As String)
'''    Dim rsReport As ADODB.Recordset
'''    Dim itmTemp As ListItem
'''
'''    Screen.MousePointer = vbArrowHourglass
'''    '借用rsReport
'''    Set rsReport = New ADODB.Recordset
'''    rsReport.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'''    lvwSJRY.ListItems.Clear
'''    If Not rsReport.EOF Then
'''        rsReport.MoveFirst
'''        Do
'''            Set itmTemp = lvwSJRY.ListItems.Add(, "W" & rsReport("流水号"), rsReport(g_strSystemIDTitle))
'''            itmTemp.SubItems(1) = rsReport(g_strSelfIDTitle) & ""
'''            itmTemp.SubItems(2) = rsReport("体检序号")
'''            itmTemp.SubItems(3) = rsReport("姓名")
'''            itmTemp.SubItems(4) = rsReport("性别") & ""
'''            itmTemp.SubItems(5) = rsReport("身份证号") & ""
'''            itmTemp.SubItems(6) = rsReport("体检日期")
'''
'''            rsReport.MoveNext
'''        Loop Until rsReport.EOF
'''        rsReport.Close
'''
'''        '选中第一行
'''        Set lvwSJRY.SelectedItem = lvwSJRY.ListItems(1)
'''        lvwSJRY_ItemClick lvwSJRY.SelectedItem
'''    End If
'''    Screen.MousePointer = vbdefalut
'''End Function

Private Sub cmdPrint_Click()
    If Not gRegister Then
        MsgBox "您现在使用的是未注册版本！不能使用报表打印功能！", vbExclamation, "提示"
        Exit Sub
    End If

Cell1.DoPrint True
End Sub

Private Sub Form_Load()
'    Call SetObjectTitleAndWidth(Me.lvwSJRY, 1, 2)
    Cell1.DoSetColWidth 0, 190
    Cell1.DoSetColWidth 1, 150
    Cell1.DoSetColWidth 2, 150
    Cell1.DoSetColWidth 3, 150
    Cell1.DoSetColWidth 4, 150
    Cell1.DoLogin "北京和风技贸有限公司", 281, "00FD18FF080193035CFE09FFDC09"
    ReadHeadFoot
    
    Cell1.DoSetPrintHead txtHead(0).Text, txtHead(1).Text, txtHead(2).Text
    Cell1.DoSetPrintFoot txtFoot(0).Text, txtFoot(1).Text, txtFoot(2).Text
    Cell1.DoSetBackGround 4
     Set Me.Icon = FrmQuery_MBBB.Icon
End Sub


Private Sub lvwSJRY_ItemClick(ByVal item As MSComctlLib.ListItem)
    lngGUID = Val(Mid(item.Key, 2))
    showReport lngGUID
    DoEvents
End Sub
Private Sub ReadHeadFoot()
    Dim rs As New ADODB.Recordset
    Dim str() As String
    rs.Open "select * from SET_SYSTEM where SYSTEMNAME='RptHead'", GCon, adOpenStatic, adLockOptimistic
    If rs.RecordCount >= 1 Then
        If rs.Fields(1) <> "" Then
            str = Split(rs.Fields(1), ",")
            txtHead(0).Text = str(0)
            txtHead(1).Text = str(1)
            txtHead(2).Text = str(2)
        End If
    Else
        GCon.Execute "insert into SET_SYSTEM values('RptHead','')"
    End If
    rs.Close
    rs.Open "select * from SET_SYSTEM where SYSTEMNAME='RptFoot'", GCon, adOpenStatic, adLockOptimistic
    If rs.RecordCount >= 1 Then
        If rs.Fields(1) <> "" Then
            str = Split(rs.Fields(1), ",")
            txtFoot(0).Text = str(0)
            txtFoot(1).Text = str(1)
            txtFoot(2).Text = str(2)
        End If
    Else
        GCon.Execute "insert into SET_SYSTEM values('RptFoot','')"
    End If
    rs.Close
End Sub




Private Sub txtFoot_Click(Index As Integer)
    XPCmdNum.Tag = "F" & Index
    XPCmdSum.Tag = "F" & Index
End Sub

Private Sub txtHead_Click(Index As Integer)
    XPCmdNum.Tag = "H" & Index
    XPCmdSum.Tag = "H" & Index
End Sub

Private Sub XPCmdExit_Click()
    Unload Me
End Sub

Private Sub XPCmdExport_Click()
On Error GoTo er
    CmmDlg.DialogTitle = "保存为"
    CmmDlg.CancelError = True
'    CmmDlg.Flags = cdlOFNNoReadOnlyReturn & cdlOFNOverwritePrompt
    CmmDlg.Filter = "Excel文件(*.xls)|*.xls|Web文件(*.Html)|*.Html"
    CmmDlg.FileName = "通用报告-" & strName
    CmmDlg.ShowSave
    If CmmDlg.FilterIndex = 1 Then
        If Cell1.DoExportExcelFile(CmmDlg.FileName) = 1 Then
            MsgBox "保存完毕！", vbInformation, "提示"
        Else
            MsgBox "保存失败！", vbInformation, "提示"
        End If
    
    End If
    If CmmDlg.FilterIndex = 2 Then
        If Cell1.DoSaveHtmlFile(CmmDlg.FileName) = 1 Then
            MsgBox "保存完毕！", vbInformation, "提示"
        End If
    End If
    Exit Sub
er:
MsgBox Err.Description
End Sub

Private Sub XPCmdNum_Click()
    If Left(XPCmdNum.Tag, 1) = "H" Then
        txtHead(Right(XPCmdNum.Tag, 1)).Text = txtHead(Right(XPCmdNum.Tag, 1)).Text & "第&P页"
    Else
        txtFoot(Right(XPCmdNum.Tag, 1)).Text = txtFoot(Right(XPCmdNum.Tag, 1)).Text & "第&P页"
    End If
End Sub

Private Sub XPCmdPageSet_Click()
Cell1.DoPrintPageSetup
End Sub

Private Sub XPCmdPrview_Click()
    If Not gRegister Then
        MsgBox "您现在使用的是未注册版本！不能使用报表预览功能！", vbExclamation, "提示"
        Exit Sub
    End If

Cell1.DoPrintPreview True
End Sub


Private Sub AddPic(ByVal strCell As String, _
                    ByVal strPic As String, _
                    ByVal lngLine As Long, _
                    ByVal lngColor As Long, _
                    ByVal lngFontSize As Long, _
                    ByVal lngFontStyle As Long, _
                    ByVal FontName As String, _
                    ByVal lngFrontColor As Long, _
                    ByVal lngBackColor As Long)
    Dim i As Integer
    Cell1.DoAppendRow 1
    Cell1.DoSetCellString 0, Cell1.Rows - 1, strCell
    Cell1.DoSetCellPicture 1, Cell1.Rows - 1, strPic, 3
    Cell1.DoJoinCells 1, Cell1.Rows - 1, 4, Cell1.Rows - 1
    Cell1.DoSetRowHeight Cell1.Rows - 1, 400
    If Cell1.Rows = 1 Then
        Cell1.DoDrawLine 0, Cell1.Rows - 1, 4, Cell1.Rows - 1, 1, lngLine, lngColor
    Else
        For i = 0 To 4
            Cell1.DoDrawLine i, Cell1.Rows - 1, 4, Cell1.Rows - 1, 2, lngLine, lngColor
            If i = 4 Then
                Cell1.DoDrawLine i, Cell1.Rows - 1, 4, Cell1.Rows - 1, 3, lngLine, lngColor
            End If
            Cell1.DoDrawLine i, Cell1.Rows - 1, 4, Cell1.Rows - 1, 5, lngLine, lngColor
            Cell1.DoSetCellAlignment i, Cell1.Rows - 1, 4
        Next
    End If
    Cell1.DoSetCellFont 0, Cell1.Rows - 1, lngFontSize, lngFontStyle, lngFontName
    Cell1.DoSetCellAlignment 0, Cell1.Rows - 1, 36
End Sub


Private Sub XPCmdSave_Click()
    GCon.Execute "update set_system set SYSTEMPROPERTY='" & txtHead(0).Text & "," & txtHead(1).Text & "," & txtHead(2).Text & "' where SYSTEMNAME='RptHead'"
    GCon.Execute "update set_system set SYSTEMPROPERTY='" & txtFoot(0).Text & "," & txtFoot(1).Text & "," & txtFoot(2).Text & "' where SYSTEMNAME='RptFoot'"
    
    Cell1.DoSetPrintHead txtHead(0).Text, txtHead(1).Text, txtHead(2).Text
    Cell1.DoSetPrintFoot txtFoot(0).Text, txtFoot(1).Text, txtFoot(2).Text
    MsgBox "保存完毕!", vbInformation
End Sub

Private Sub XPCmdSum_Click()
    If Left(XPCmdNum.Tag, 1) = "H" Then
        txtHead(Right(XPCmdNum.Tag, 1)).Text = txtHead(Right(XPCmdNum.Tag, 1)).Text & "总页数&S"
    Else
        txtFoot(Right(XPCmdNum.Tag, 1)).Text = txtFoot(Right(XPCmdNum.Tag, 1)).Text & "总页数&S"
    End If
End Sub