mdldatabase3.bas

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

        
        '打印科室名称
        If rstemp("KSMC") <> strOldKShi Then
            If intCurrentCol = 1 Then
                sngCurrX = sngKShi_First
                '如果不是第一页第一行，则打印横线
                If Not ((intLineCount = 1) And (intCurrentCol = 1) And (intPage = 1)) Then
                    Printer.Line (sngFlag_First - 1, sngCurrY - 1)-(sngFlag_Second - 1, sngCurrY - 1)
                End If
            Else
                sngCurrX = sngKShi_Second
                '第二列
                Printer.Line (sngFlag_Second - 1, sngCurrY - 1)-(Printer.ScaleWidth - (sngFlag_First - 1), sngCurrY - 1)
            End If
            '科室名称用粗体
            fntCurrFont.Bold = True
            Call PrintContents(fntCurrFont, rstemp("KSMC"), sngCurrX, sngCurrY)
            '恢复字体
            fntCurrFont.Bold = False
            
            strOldKShi = rstemp("KSMC")
        End If
        
        '打印项目
        If intCurrentCol = 1 Then
            sngCurrX = sngXMu_First
        Else
            sngCurrX = sngXMu_Second
        End If
        Call PrintContents(fntCurrFont, rstemp("DXMC"), sngCurrX, sngCurrY)
        
        '重新设置纵坐标
        sngCurrY = sngCurrY + Printer.TextHeight("高度") + sngLineInterval
        intLineCount = intLineCount + 1 '行数加1
        '移动记录集
        rstemp.MoveNext
    Loop
    
    '是否需要打印合计
    If blnPrintMoney Then
        If sngCurrY > sngPageBottomTop Then
            If intCurrentCol = 2 Then
                intCurrentCol = 1
            End If
        End If
        If intCurrentCol = 1 Then
            sngCurrX = sngKShi_First
            Printer.Line (sngFlag_First - 1, sngCurrY - 1)-(sngFlag_Second - 1, sngCurrY - 1)
        Else
            sngCurrX = sngKShi_Second
            Printer.Line (sngFlag_Second - 1, sngCurrY - 1)-(Printer.ScaleWidth - (sngFlag_First - 1), sngCurrY - 1)
        End If
        Call PrintContents(fntCurrFont, "合计：" & CStr(curTotal) & " 元", sngCurrX, sngCurrY)
    End If
    
    '提交打印
    Printer.EndDoc
    
    GoTo ExitLab
    
'打印线条
PrintLine:
    Printer.DrawWidth = 2
    Printer.DrawStyle = vbSolid
    Printer.Line (sngLineLeft, sngLineTop)-(sngLineLeft + sngLineWidth, sngLineTop)
    Return
'绘制网格
DrawGrid:
    sngTopLineTop = sngContentBeginTop - 1
    sngBottomLineTop = sngPageBottomTop + Printer.TextHeight("高度") + 1
    '顶端横线
    Printer.Line (sngLineLeft, sngTopLineTop)-(sngLineLeft + sngLineWidth, sngTopLineTop)
    '第一条竖线
    Printer.Line (sngFlag_First - 1, sngTopLineTop)-(sngFlag_First - 1, sngBottomLineTop)
    '第二条竖线
    Printer.Line (sngKShi_First - 1, sngTopLineTop)-(sngKShi_First - 1, sngBottomLineTop)
    '第三条竖线
    Printer.Line (sngFlag_Second - 1, sngTopLineTop)-(sngFlag_Second - 1, sngBottomLineTop)
    '第四条竖线
    Printer.Line (sngKShi_Second - 1, sngTopLineTop)-(sngKShi_Second - 1, sngBottomLineTop)
    '第五条（最后一条）竖线
    Printer.Line (Printer.ScaleWidth - (sngFlag_First - 1), sngTopLineTop)- _
            (Printer.ScaleWidth - (sngFlag_First - 1), sngBottomLineTop)
    '底部横线
    Printer.Line (sngFlag_First - 1, sngBottomLineTop)-(Printer.ScaleWidth - (sngFlag_First - 1), sngBottomLineTop)
    Return
    
'打印表头
PrintTitle:
    With Printer
        .FontName = "宋体"
        .FontSize = 15
        .FontBold = True
        .FontItalic = False
        .FontUnderline = False
        
        .CurrentY = sngTitleTop
        If Not blnCompose Then
            If intPage = 1 Then
                .CurrentX = (.ScaleWidth - .TextWidth("体检导引单")) / 2
                Printer.Print "体检导引单"
            Else
                .CurrentX = (.ScaleWidth - .TextWidth("体检导引单(续)")) / 2
                Printer.Print "体检导引单(续)"
            End If
        Else
            If intPage = 1 Then
                .CurrentX = (.ScaleWidth - .TextWidth("体检项目列表")) / 2
                Printer.Print "体检项目列表"
            Else
                .CurrentX = (.ScaleWidth - .TextWidth("体检项目列表(续)")) / 2
                Printer.Print "体检项目列表(续)"
            End If

        End If
        .FontSize = 11
        If Not blnCompose Then
            .CurrentY = sngHospitalTop
        Else
            .CurrentY = sngHospitalTop + 3
        End If
        .CurrentX = (.ScaleWidth - .TextWidth(gstrHospital)) / 2
        Printer.Print gstrHospital
    End With
    Return
    
'打印个人信息
PrintPersonInfo:
    With Printer
        .FontName = "宋体"
        .FontSize = 11
        .FontBold = True
        .FontItalic = False
        .FontUnderline = False
        '姓名
        .CurrentX = sngPersonNameLeft
        .CurrentY = sngPersonInfoTop
        Printer.Print "姓名：" & strPersonName
        '性别
        .CurrentX = sngPersonSexLeft
        .CurrentY = sngPersonInfoTop
        Printer.Print "性别：" & strPersonSex
        '年龄
        .CurrentX = sngPersonAgeLeft
        .CurrentY = sngPersonInfoTop
        Printer.Print "年龄：" & strPersonAge
        '身份证号
        .CurrentX = sngPersonCardLeft
        .CurrentY = sngPersonInfoTop
        Printer.Print "身份证号：" & strPersonCard
        '档案号
        .CurrentX = sngPersonArchiveLeft
        .CurrentY = sngPersonInfoTop
        Printer.Print "档案号：" & strPersonArchive
        '客户单位
        .CurrentX = sngPersonUnitLeft
        .CurrentY = sngPersonUnitTop
        Printer.Print "单位：" & strPersonUnit
    End With
    Return
    
ExitLab:
    '
End Sub

'**********************************************************************
'打印导引单，采用青岛大学医学院模式
'参数1：表示某个客户的唯一编号
'返回值：无
'**********************************************************************
Public Function PrintPersonGuider_QDU(ByVal lngGUID As Long, _
        Optional ByVal strPreviousSelection As String) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    Dim strYYID As String
    Dim intFZID As Integer
    Dim strTempFile As String '临时文件名
    Dim strTemplateFile As String '格式文件名
    Dim strPrinter As String '打印机名称
    Dim blnShowChild As Boolean '是否显示小项
    Dim intKeyNumber As Integer '关键字数目
    Dim blnOther As Boolean '是否最后一种
    Dim strKeyWord() As String '关键字
    Dim strKeyCode() As String '编码
    Dim lngPrintTime As Long '打印等待时间
    Dim strGuiders() As String '导引单种类名称数组
    Dim blnSelectedIndex() As Boolean '某种编号的导引单是否需要打印
    Dim strRetIndex As String
    Dim arrRetIndex
    Dim blnAll As Boolean '是否打印全部项目
    
    Dim strCurrentKeyWord As String '当前格式的关键字
    Dim strAllKeyWord As String '所有关键字
    Dim strValue As String 'ini文件临时值
    Dim strConfigFile As String '配置文件名
    Dim intGuiderNumber As Integer '格式数目
    Dim intGuiderIndex As Integer '格式索引
    Dim intKeyIndex As Integer '关键字索引
    Dim intPosition As Integer '位置
    '以下声明用于Word模板
    Dim WordTemps As Word.Application
    Dim docTemps As Word.Document
    Dim bookColls As Word.Bookmarks
    Dim bookColl As Word.Bookmark
    Dim bookCollChild As Word.Bookmark
    Dim strBookName As String '书签名
    Dim strBookNameOfTotalPrice As String '总价格的书签名
    Dim curTotalPricePerPage As Currency
    Dim strHeader As String
    Dim strID As String
    Dim strPrint As String
    Dim intXMCount As Integer  '
    Dim intXMIndex As Integer
    Dim i As Integer, j As Integer, K As Integer
    Dim blnNoSelection As Boolean
    
    blnNoSelection = False
    '检查在表YY_SJDJDX中有无数据
    strSQL = "select Count(*) from YY_SJDJDX" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rstemp(0) > 0 Then
        rstemp.Close
    Else
        rstemp.Close
        '说明是从预约时进来的团检人员，尚未登记
        '获取团检编号和分组编号
        strSQL = "select YYID,FZID from FZ_FZSJ" _
                & " where GUID=" & lngGUID
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If Not rstemp.EOF Then
            strYYID = rstemp("YYID")
            intFZID = rstemp("FZID")
            blnNoSelection = True
            
            rstemp.Close
        End If
    End If
    
    strConfigFile = gstrCurrPath & TemplateDir & GuiderConfig
    '文件是否存在
    If Dir(strConfigFile) = "" Then
        MsgBox "目前采用的导引单模式是自定义模式。找不到相应配置文件：" & strConfigFile, _
                vbExclamation, "提示"
        GoTo ExitLab
    End If
    
    '获取导引单格式数目
    strValue = GetINI(strConfigFile, "GuiderSet", "GuiderNumber", "")
    intGuiderNumber = CInt(Val(strValue))
    '不能低于一种格式
    If intGuiderNumber < 1 Then GoTo ExitLab
    '定义数组
    ReDim blnSelectedIndex(1 To intGuiderNumber)
    '是否需要用户选择
    If intGuiderNumber < 1 Then
        '只有一种格式的情况
        blnSelectedIndex(1) = True
    Else
        ReDim strGuiders(1 To intGuiderNumber)
        '检索所有存在的格式，以便用户选择
        For i = 1 To intGuiderNumber
            strValue = GetINI(strConfigFile, "Guider" & CStr(i), "TemplateFile", "")
            strValue = Trim(strValue)
            If strValue <> "" Then
                If UCase(Right(strValue, 4)) = ".DOC" Then
                    strValue = Left(strValue, Len(strValue) - 4)
                End If
                If InStr(1, UCase(strValue), "OTHER") >= 1 Then
                    strValue = "其它"
                End If
                If InStr(1, UCase(strValue), "ALL") >= 1 Then
                    strValue = "全部"
                End If
                strGuiders(i) = strValue
            End If
        Next
        
        If strPreviousSelection = "" Then
            If intGuiderNumber > 1 Then
                strRetIndex = dlgSelectGuider.ShowGuiders(strGuiders)
                Set dlgSelectGuider = Nothing
            Else
                strRetIndex = "1"
            End If
        Else
            strRetIndex = strPreviousSelection
        End If
        If strRetIndex = "" Then GoTo ExitLab
        arrRetIndex = Split(strRetIndex, ",")
        For i = LBound(arrRetIndex) To UBound(arrRetIndex)
            blnSelectedIndex(arrRetIndex(i)) = True
        Next
        
        PrintPersonGuider_QDU = strRetIndex
    End If
    
    Screen.MousePointer = vbHourglass
    
    '检索打印等待时间
    strValue = GetINI(strConfigFile, "GuiderSet", "PrintTime", "")
    lngPrintTime = CLng(Val(strValue))
    If lngPrintTime > 100000 Or lngPrintTime < 1 Then
        lngPrintTime = 100
    End If
    
    '
'      strTempFile = GetFileName(Me.CommonDialog1, "Word文档(*.doc)|*.doc", _
'                        "客户" & lngGUID & " 的报表保存为", _
'                         WRITEFILE)
    '
    '创建word对象
    Set WordTemps = New Word.Application
    '临时文件