mdlfunction2.bas

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

Attribute VB_Name = "mdlFunction2"
Option Explicit

Public Enum OfficeEnum
    NONE_W = 0
    WORD_W = 1
    EXCEL_W = 2
End Enum

Public g_lngPrintLoopInterval As Long
Public g_lngPrintTimeOut As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const CB_FINDSTRING = &H14C

'*************************************************************************
'*************************************************************************
'*********************                              **********************
'*********************          打印Office文档       **********************
'*********************                              **********************
'*************************************************************************
'*************************************************************************
Public Function PrintOfficeDocument(ByVal strFileName As String, _
        ByVal enuOfficeEnum As OfficeEnum, _
        Optional ByVal strExcelSheetName As String) As Boolean
'参数1：欲打印的文件名
'参数2：欲打印文件的类型。目前支持两种文件：Word，Excel
'返回值：成功为True，否则为False
On Error GoTo ErrMsg
    Dim Status
    Dim strDirPath As String
    '以下变量声明用于Excel文件
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim strSheetName
    Dim i As Integer
    
    Screen.MousePointer = vbArrowHourglass
    
    '获取文件夹
    strDirPath = Left(strFileName, InStrRev(strFileName, "\") - 1)
    
    Select Case enuOfficeEnum
        Case WORD_W
            
        Case EXCEL_W
            Set xlApp = CreateObject("Excel.Application")
            Set xlBook = Nothing
            Set xlSheet = Nothing
            Call ChDir(strDirPath)
            Set xlBook = xlApp.Workbooks.Open(FileName:=strFileName)
            
            '设置默认打印机
            Call SetDefaultPrinter(g_strReportPrinter, EXCEL_W, , xlApp)
    
            strSheetName = Split(strExcelSheetName, ",")
            For i = LBound(strSheetName) To UBound(strSheetName)
                Set xlSheet = xlBook.Sheets(strSheetName(i))
                xlSheet.Select
                Call xlSheet.PrintOut(Copies:=1)
            Next i
        Case Else
            '
    End Select
    
    PrintOfficeDocument = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    Screen.MousePointer = vbDefault
End Function

'打印word文档
Public Sub PrintWordDocument(ByRef WordTemps As Word.Application, ByVal strFileName As String)
    Dim lngPassedTime As Long
    
    Call LoadPrintSet
    '设置默认打印机
    Call SetDefaultPrinter(g_strReportPrinter, WORD_W, WordTemps)
    Call WordTemps.PrintOut(FileName:="""" & strFileName & """", Range:=wdPrintAllDocument, item:= _
            wdPrintDocumentContent, Copies:=1, Pages:="", PageType:=wdPrintAllPages, _
            ManualDuplexPrint:=False, Collate:=True, background:=True, PrintToFile:= _
            False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
            PrintZoomPaperHeight:=0)
    Do
        Call TimeDelay(g_lngPrintLoopInterval)
        
        lngPassedTime = lngPassedTime + g_lngPrintLoopInterval
        If lngPassedTime > g_lngPrintTimeOut Then Exit Do
    Loop While WordTemps.BackgroundPrintingStatus > 0
    Call TimeDelay(g_lngPrintLoopInterval)
End Sub

'保存Word文档
Public Function SaveWordDocument(ByVal WordTemps As Word.Application, _
        ByVal docTemps As Word.Document, ByVal strFileName As String) As Boolean
    Dim lngPassedTime As Long
    
    If Dir(strFileName) <> "" Then Kill strFileName
    docTemps.SaveAs strFileName
    
    Call LoadPrintSet
    Do
        Call TimeDelay(g_lngPrintLoopInterval)
        
        lngPassedTime = lngPassedTime + g_lngPrintLoopInterval
        If lngPassedTime > g_lngPrintTimeOut Then Exit Do
    Loop While WordTemps.BackgroundSavingStatus > 0
    Call TimeDelay(g_lngPrintLoopInterval)
End Function

'获取打印设置
Private Sub LoadPrintSet()
    Dim strValue As String
    
    '获取报表打印机
    g_strReportPrinter = Trim(GetINI(gstrCurrPath & DSNINIFile, "PrintSet", "ReportPrinter", ""))
    
    '循环检测时间
    strValue = Trim(GetINI(gstrCurrPath & DSNINIFile, "PrintSet", "LoopInterval", ""))
    g_lngPrintLoopInterval = CLng(Val(strValue))
    If g_lngPrintLoopInterval < 50 Or g_lngPrintLoopInterval > 300000 Then
        g_lngPrintLoopInterval = 100
    End If
    
    'office操作超时时间
    strValue = Trim(GetINI(gstrCurrPath & DSNINIFile, "PrintSet", "LoopTimeOut", ""))
    g_lngPrintTimeOut = CLng(Val(strValue))
    If g_lngPrintTimeOut < 50 Or g_lngPrintTimeOut > 600000 Then
        g_lngPrintTimeOut = 600000
    End If
    If g_lngPrintTimeOut < g_lngPrintLoopInterval Then g_lngPrintTimeOut = g_lngPrintLoopInterval
End Sub

'在指定组合框中搜寻匹配的项目
Public Function FindItemInCombox(ByVal lngHWnd As Long, ByVal strItem As String) As Long
    FindItemInCombox = SendMessage(lngHWnd, CB_FINDSTRING, -1, ByVal strItem)
End Function

'选中一个文本框中指定起始范围内的内容
Public Sub SelectContents(ByRef txtBox As TextBox, _
        Optional ByVal lngStart As Long = 0, _
        Optional ByVal lngSelLength As Long = -1)
    txtBox.SelStart = lngStart
    txtBox.SelLength = IIf(lngSelLength < 0, Len(txtBox.Text), lngSelLength)
End Sub

'调整显示顺序
Public Sub MoveLocation(ByVal strTable As String, ByVal strSXHField As String, _
        ByVal strPrimaryField As String, _
        ByVal strCurrDMID As String, ByVal strAdjustedDMID As String, _
        Optional ByVal blnUpToDown As Boolean = True)
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    Screen.MousePointer = vbArrowHourglass
    
    strSQL = "update " & strTable & " set" _
            & " " & strSXHField & "=" & strSXHField
    If blnUpToDown Then
        strSQL = strSQL & "-"
    Else
        strSQL = strSQL & "+"
    End If
    strSQL = strSQL & "1 where " & strPrimaryField & "='" & strAdjustedDMID & "'"
    GCon.Execute strSQL
    
    strSQL = "update " & strTable & " set" _
            & " " & strSXHField & "=" & strSXHField
    If blnUpToDown Then
        strSQL = strSQL & "+"
    Else
        strSQL = strSQL & "-"
    End If
    strSQL = strSQL & "1 where " & strPrimaryField & "='" & strCurrDMID & "'"
    GCon.Execute strSQL
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

'在树型结构中加载所有科室和项目
Public Function LoadKeShiAndXiangMu(ByRef tvwXMu As TreeView) As Boolean
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsKS As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    Dim nodTemp As Node
    
    Screen.MousePointer = vbHourglass
    '获取所有科室
    strSQL = "select KSID,KSMC from SET_KSSZ" _
            & " order by SXH"
    Set rsKS = New ADODB.Recordset
    rsKS.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rsKS.EOF Then
        MsgBox "当前尚未添加任何科室，无法进行其它操作！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '添加根节点
    Set nodTemp = tvwXMu.Nodes.Add(, , HEADER, "所有科室")
    nodTemp.Expanded = True
    
    '循环添加所有科室
    With tvwXMu
        Do
            '关键字长度：1＋2＝3
            Set nodTemp = .Nodes.Add(HEADER, tvwChild, HEADER & rsKS("KSID"), rsKS("KSMC"))
            
            '检索该科室下的所有体检项目
            strSQL = "select XXID,XXMC from SET_XX" _
                    & " where KSID='" & rsKS("KSID") & "'" _
                    & " order by SXH"
            Set rsXX = New ADODB.Recordset
            rsXX.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
            If Not rsXX.EOF Then
                Do
                    '关键字长度：1＋7＝8
                    .Nodes.Add HEADER & rsKS("KSID"), tvwChild, HEADER & rsXX("XXID"), rsXX("XXMC")
                    
                    rsXX.MoveNext
                Loop While Not rsXX.EOF
                rsXX.Close
            End If
            
            rsKS.MoveNext
        Loop While Not rsKS.EOF
    End With
    rsKS.Close
    
    Set tvwXMu.SelectedItem = tvwXMu.Nodes(1)
    
    LoadKeShiAndXiangMu = True
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'控制树型复选框的选中状态
Public Sub ManipunateCheckTree(ByRef tvwTree As TreeView, ByRef nodSelected As Node)
On Error Resume Next
    Dim i As Integer
    Dim intIndex As Integer
    
    With tvwTree
        '处理子节点
        Call ManipunateChildNode(tvwTree, nodSelected)
        
        '处理父节点
        Call ManipunateParentNode(tvwTree, nodSelected)
    End With
End Sub

'递归处理节点所有子节点
Private Sub ManipunateChildNode(ByRef tvwTree As TreeView, ByRef nodSelected As Node)
    Dim intIndex As Integer
    
    With nodSelected
        If .Children > 0 Then
            .Child.Checked = .Checked
            If .Child.Children > 0 Then Call ManipunateChildNode(tvwTree, .Child)
            intIndex = .Child.Index
            
            Do While intIndex <> .Child.LastSibling.Index
                tvwTree.Nodes(intIndex).Next.Checked = .Checked
                If .Child.Children > 0 Then Call ManipunateChildNode(tvwTree, tvwTree.Nodes(intIndex).Next)
                intIndex = tvwTree.Nodes(intIndex).Next.Index
            Loop
        End If
    End With
End Sub

'递归处理节点所有父节点
Private Sub ManipunateParentNode(ByRef tvwTree As TreeView, ByRef nodSelected As Node)
    Dim intIndex As Integer
    Dim blnChecked As Boolean '是否选中
    
    With nodSelected
        '父节点是否存在
        If Not (.Parent Is Nothing) Then
            If .Checked = True Then
                '如果当前节点选中，则选中其父节点
                .Parent.Checked = .Checked
                Call ManipunateParentNode(tvwTree, .Parent)
            Else
                '如果当前节点没有选中，检查同一级的节点是否都已取消
                blnChecked = False
                intIndex = .FirstSibling.Index
                '检查最后一个节点以外的节点
                Do While intIndex <> .LastSibling.Index
                    If tvwTree.Nodes(intIndex).Checked Then
                        blnChecked = True
                        Exit Do
                    End If
                    intIndex = tvwTree.Nodes(intIndex).Next.Index
                Loop
                '如果前面全部没有选中，则检查最后一个节点
                If Not blnChecked Then
                    If .LastSibling.Checked Then blnChecked = True
                End If
                '该层是否有选中
                If Not blnChecked Then
                    .Parent.Checked = .Checked
                    Call ManipunateParentNode(tvwTree, .Parent)
                End If
            End If
        End If
    End With
End Sub