mdldatabase2.bas

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

Attribute VB_Name = "mdlDatabase2"
Option Explicit
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

'获取某人的体检异常结论
Public Function GetTJYCJLun(ByVal lngGUID As Long) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsJBCJB  As ADODB.Recordset
    Dim rsZJJL As ADODB.Recordset
    Dim strRet As String
    Dim intJBCJB As Integer
    
    '获取当前客户的所有体检结论
    strSQL = "select JLValue from DATA_ZJJL" _
            & " where GUID=" & lngGUID
    Set rsZJJL = New ADODB.Recordset
    rsZJJL.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    '如果没有记录，则直接退出
    If rsZJJL.RecordCount = 0 Then GoTo ExitLab
    
    '提取所有病症
    strSQL = "select JYMC from DM_ZJJY"
    Set rsJBCJB = New ADODB.Recordset
    rsJBCJB.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rsJBCJB.RecordCount > 0 Then
        intJBCJB = 1 '初始化疾病编号
        strRet = "" '初始化返回值
        rsJBCJB.MoveFirst
        Do While Not rsJBCJB.EOF
            '循环处理该单位每个客户的总检结论
            If InStr(1, rsZJJL("JLValue"), rsJBCJB("JYMC")) >= 1 Then
                strRet = strRet & "（" & intJBCJB & "）：" & rsJBCJB("JYMC") & vbCrLf
                intJBCJB = intJBCJB + 1
            End If
            
            rsJBCJB.MoveNext
        Loop
        
        rsJBCJB.Close
    End If
    '是否有异常
    If strRet <> "" Then
        '截掉最后的回车换行
        strRet = Left(strRet, Len(strRet) - 2)
    End If
    '释放内存
    rsZJJL.Close
    Set rsJBCJB = Nothing
    Set rsZJJL = Nothing
    
    GetTJYCJLun = strRet '返回
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'获取当前机器的用户名
Public Function GetUserNameW() As String
    Dim strUserName As String
    
    strUserName = String(256, Chr(0))
    Call GetUserName(strUserName, 256)
    'strip the rest of the buffer
    strUserName = Left(strUserName, InStr(strUserName, Chr(0)) - 1)
    GetUserNameW = strUserName
End Function

'获取本机机器名
Public Function GetComputerNameW() As String
    Dim strComputerName As String
    
    strComputerName = String(256, Chr(0))
    Call GetComputerName(strComputerName, 256)
    'strip the rest of the buffer
    strComputerName = Left(strComputerName, InStr(strComputerName, Chr(0)) - 1)
    GetComputerNameW = strComputerName
End Function



'*************************************************************************
'*************************************************************************
'*********************                              **********************
'*********************      打印用户自定义报表       **********************
'*********************                              **********************
'*************************************************************************
'*************************************************************************
Public Sub PrintCustomDatabase(ByVal lngGUID As Long, ByVal strBBID As String, _
        ByRef pictemp As PictureBox, ByRef txtTemp As TextBox, _
        ByVal frmParent As Form, ByRef objPrint As Object)
On Error GoTo ErrMsg
    Dim Status
    Dim strPYSX As String
    Dim strDXPYSX As String
    Dim strSQL As String
    Dim rsReport As ADODB.Recordset
    Dim rstemp As ADODB.Recordset
    Dim rsPerson As ADODB.Recordset
    Dim strTag As String
    Dim intFlag As Integer
    Dim strID As String
    Dim strFormat As String
    Dim arrFormat
    Dim strPrint As String
    Dim i As Integer
    Dim strTempFile As String
    Dim blnMultiline As Boolean
    Dim intCount As Integer '文本框的行数
    Dim strLine As String '文本框里的每一行文本
    
    '******************20040415加入 闻********************************
    Dim tmpYYID As String
    Dim tmpFZID As Integer
    Dim tmpTCID As Integer
    '******************20040415加入完 闻********************************
    
    Dim sngTop As Single '当前要打印内容的左上角的横坐标
    Dim sngLeft As Single '当前要打印内容的左上角的纵坐标
    
    Screen.MousePointer = vbArrowHourglass
    
    '设成A4纸
    objPrint.ScaleMode = vbMillimeters
'    objPrint.ScaleWidth = 210
'    objPrint.ScaleHeight = 297
    
    '临时文件
    strTempFile = Environ("TEMP") & "\dhtj.jpg"
    
    '获取用户常用信息
    strSQL = "select * from SET_GRXX" _
            & " where GUID=" & lngGUID
    Set rsPerson = New ADODB.Recordset
    rsPerson.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rsPerson.EOF Then GoTo ExitLab
    
    '根据报表纸型设置objPrint的长度和宽度
    strSQL = "select * from Report_MC" _
            & " where BBID='" & strBBID & "'"
    Set rsReport = New ADODB.Recordset
    rsReport.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If objPrint Is Printer Then
        Select Case rsReport("BBZX")
            Case "A4"
'                objPrint.PaperSize = vbPRPSA4
                objPrint.ScaleWidth = 210
                objPrint.ScaleHeight = 297
            Case "B5"
'                objPrint.PaperSize = vbPRPSB5
                objPrint.ScaleWidth = 182
                objPrint.ScaleHeight = 257
            Case "A3"
'                objPrint.PaperSize = vbPRPSA3
                objPrint.ScaleWidth = 297
                objPrint.ScaleHeight = 420
            Case "16K"
'                objPrint.PaperSize = vbPRPSA4
                objPrint.ScaleWidth = 184
                objPrint.ScaleHeight = 260
        End Select
    Else
        Select Case rsReport("BBZX")
            Case "A4"
                objPrint.Width = 210
                objPrint.Height = 297
            Case "B5"
                objPrint.Width = 182
                objPrint.Height = 257
            Case "A3"
                objPrint.Width = 297
                objPrint.Height = 420
            Case "16K"
                objPrint.Width = 184
                objPrint.Height = 260
        End Select
    End If
    rsReport.Close
    
    If Not (objPrint Is Printer) Then objPrint.Cls
    
    '获取报表结构
    strSQL = "select * from REPORT_DT" _
            & " where BBID='" & strBBID & "'" _
            & " order by ReportIndex"
    Set rsReport = New ADODB.Recordset
    rsReport.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsReport.RecordCount > 0 Then
        objPrint.DrawWidth = 1
        objPrint.DrawStyle = 0
        
        rsReport.MoveFirst
        With objPrint
            .ForeColor = RGB(0, 0, 0)
            Do
                '绘制报表
                If rsReport("ReportType") = WLine Then
                    '************************************************************************
                    '画线
                    '************************************************************************
                    objPrint.Line (rsReport("ReportLeft"), rsReport("ReportTop"))-(rsReport("ReportWidth"), rsReport("ReportHeight"))
                ElseIf rsReport("ReportType") = WText Then
                    '************************************************************************
                    '静态文本
                    '************************************************************************
                    strFormat = rsReport("ReportFormat")
                    arrFormat = Split(strFormat, ",")
                    
                    '设置字体
                    .FontName = arrFormat(0)
                    .FontSize = arrFormat(1)
                    .FontBold = arrFormat(2)
                    .FontItalic = arrFormat(3)
                    .FontUnderline = arrFormat(4)
''                    .Alignment = arrFormat(5)
                    
                    '设置临时文本框的属性
                    With txtTemp
                        .FontName = arrFormat(0)
                        .FontSize = arrFormat(1)
                        .FontBold = arrFormat(2)
                        .FontItalic = arrFormat(3)
                        .FontUnderline = arrFormat(4)
    ''                    .Alignment = arrFormat(5)
                        
                        .Width = objPrint.ScaleX(rsReport("ReportWidth"), vbMillimeters, txtTemp.Container.ScaleMode) 'frmParent.ScaleX(rsReport("ReportWidth"), vbMillimeters, txtTemp.Container.ScaleMode)
                    End With
                    
                    '定位坐标
                    sngLeft = rsReport("ReportLeft")
                    sngTop = rsReport("ReportTop")
                    
                    strPrint = rsReport("ReportText")
                    GoSub PrintText
                ElseIf rsReport("ReportType") = WPhoto Then
                    '************************************************************************
                    '图片
                    '************************************************************************
                    If Not IsNull(rsReport("ReportPhoto")) Then
                        If Dir(strTempFile) <> "" Then Kill strTempFile
                        ColumnToFile rsReport("ReportPhoto"), strTempFile, rsReport
                        Set pictemp.PICTURE = LoadPicture(strTempFile)
                        '尝试两种打印方式
                        On Error Resume Next
                        Err.Clear
                        objPrint.PaintPicture pictemp.PICTURE, rsReport("ReportLeft"), rsReport("ReportTop"), rsReport("ReportWidth"), rsReport("ReportHeight")
                        If Err.Number <> 0 Then
                            Err.Clear
                            objPrint.PaintPicture pictemp.PICTURE, rsReport("ReportLeft"), rsReport("ReportTop"), rsReport("ReportWidth"), rsReport("ReportHeight"), , , , , vbSrcCopy
                        End If
                        On Error GoTo ErrMsg
                    End If
                ElseIf rsReport("ReportType") = WAuto Then
                    '************************************************************************
                    '************************************************************************
                    '                               动态文本
                    '************************************************************************
                    '************************************************************************
                    blnMultiline = False '默认值为非多行打印
                    strFormat = rsReport("ReportFormat")
                    arrFormat = Split(strFormat, ",")