frmquery_mbbb.frm

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

         Text            =   "体检套餐"
         Object.Width           =   4410
      EndProperty
   End
End
Attribute VB_Name = "FrmQuery_MBBB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mstrSQL As String
Dim mintlvPXFC As Integer       '标识lvwSJRY的排序方式,0为升序,1为降序


Private Sub chkAge_Click()
    If chkAge.Value = 1 Then
        txtAge(0).Enabled = True
        txtAge(1).Enabled = True
        txtAge(0).SetFocus
    Else
        txtAge(0).Enabled = False
        txtAge(1).Enabled = False
    End If
End Sub

Private Sub chkDate_Click()
    If chkDate.Value = 1 Then
        dtpDate(0).Enabled = True
        dtpDate(1).Enabled = True
        dtpDate(0).SetFocus
    Else
        dtpDate(0).Enabled = False
        dtpDate(1).Enabled = False
    End If
End Sub

Private Sub chkDWei_Click()
    If chkDWei.Value = 1 Then
        cmbDWei.Enabled = True
        cmbDWei.SetFocus
    Else
        cmbDWei.Enabled = False
    End If
End Sub

Private Sub chkHealthID_Click()
    If chkHealthID.Value = 1 Then
        txtHealthID.Enabled = True
        txtHealthID.SetFocus
    Else
        txtHealthID.Enabled = False
    End If
End Sub

Private Sub chkName_Click()
    If chkName.Value = 1 Then
        txtName.Enabled = True
        txtName.SetFocus
    Else
        txtName.Enabled = False
    End If
End Sub

Private Sub chkSelfBH_Click()
    If chkSelfBH.Value = 1 Then
        txtSelfBH.Enabled = True
        txtSelfBH.SetFocus
    Else
        txtSelfBH.Enabled = False
    End If
End Sub

Private Sub chkSex_Click()
    If chkSex.Value = 1 Then
        CmbSex.Enabled = True
        CmbSex.SetFocus
    Else
        CmbSex.Enabled = False
    End If
End Sub

Private Sub ChkSFZH_Click()
    If ChkSFZH.Value = 1 Then
        TxtSFZH.Enabled = True
        TxtSFZH.SetFocus
    Else
        TxtSFZH.Enabled = False
    End If
End Sub

Private Sub cmbDWei_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        KeyAscii = 0
        cmdQuery_Click
    End If
End Sub

Private Sub cmbSex_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        KeyAscii = 0
        cmdQuery_Click
    End If
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdExport_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim rsResult As ADODB.Recordset
    Dim rsKsType As ADODB.Recordset  '科室类别，wxw add 2005-08-08
    Dim rs As ADODB.Recordset
    Dim strTempPath As String '
    Dim strTempFile As String '模板文件名
    Dim strSignFile As String '签名图片
    Dim intMBID As Integer
    Dim intCount As Integer '选择的人数
    Dim arrReportFile() As String '每个客户报表存放的文件名
    Dim arrGUID() As Long '存放客户的唯一编号
    Dim SGUID As Long
    Dim strReportPath As String
    Dim intIndex As Integer '数组上限
    Dim i As Integer, j As Integer
    Dim strHeader As String
    Dim strDXPYSX As String
    Dim strXXPYSX As String
    Dim strPrint As String
    Dim strYYID As String
    Dim blnGetResult As Boolean
    Dim HEALTHID As String
    
    '以下声明用于Word模板
    Dim WordTemps As Word.Application
    Dim docTemps As Word.Document
    Dim bookColls As Word.Bookmarks
    Dim bookColl As Word.Bookmark
    Dim strBookName As String '书签名
    Dim strXMID As String
    Dim m As Integer, n As Integer
    Dim blnUnnormal As Boolean '体检项目是否正常
    Const COLOR_UNNORMAL As Long = vbRed
    Dim intSex As Integer '当前处理客户相反的性别
    Dim intType As Integer '小项类型
    Dim strTableName As String '自定义建议的表名
    Dim intJYIndex As Integer '自定义建议在记录集中的顺序
    
    Me.MousePointer = vbArrowHourglass
    
    '是否有模板
    If Me.lvwMB.ListItems.Count < 1 Then
        MsgBox "当前尚未添加任何模板，无法执行按模板导出报表！" & vbCrLf _
                & "请到“系统设置”->“报表模板维护”里面添加！如果您看不到这些菜单，请与系统管理员联系！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '是否选择了模板
    If Me.lvwMB.SelectedItem Is Nothing Then
        MsgBox "请在左下方的列表里面选择一个模板！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '是否有客户
    If Me.lvwSJRY.ListItems.Count < 1 Then
        MsgBox "当前没有需要导出报表的客户！请设置查询条件，然后单击“查询”按钮！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '是否选择了客户
    If Me.lvwSJRY.SelectedItem Is Nothing Then
        MsgBox "请选择要导出报表的客户！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    If chkDefault.Value = 1 Then
        strReportPath = BrowseForFolder(Me.hwnd, "请选择导出报表的存放路径")
        If strReportPath = "" Then GoTo ExitLab
        
        If Right(strReportPath, 1) <> "\" Then
            strReportPath = strReportPath & "\"
        End If
    End If
    
    j = 0
    '首先获取保存的文件名
    For i = 1 To Me.lvwSJRY.ListItems.Count
        If Me.lvwSJRY.ListItems(i).Selected = True Then
            ReDim Preserve arrReportFile(j)
            ReDim Preserve arrGUID(j)
            
            'GUID
            arrGUID(j) = CLng(Mid(Me.lvwSJRY.ListItems(i).Key, 2))
            '默认文件名
            arrReportFile(j) = strReportPath & Me.lvwMB.SelectedItem.Text & "_" _
                    & Me.lvwSJRY.ListItems(i).Text & "_" _
                    & Me.lvwSJRY.ListItems(i).SubItems(3) & ".doc"
            If chkDefault.Value = 0 Then '如果不采用默认文件名
                arrReportFile(j) = GetFileName(Me.CommonDialog1, "Word文档(*.doc)|*.doc", _
                        "客户 “" & Me.lvwSJRY.ListItems(i).SubItems(3) & "” 的报表保存为", _
                        arrReportFile(j), WRITEFILE)
                If arrReportFile(j) = "" Then GoTo ExitLab '一旦取消则全部取消
            End If
            
            j = j + 1
        End If
    Next i
    
    '获取临时路径
    strTempPath = GetTempPathW
    
    '生成临时模板文件
    strTempFile = strTempPath & Me.lvwMB.SelectedItem.Text & ".doc"
    If Dir(strTempFile) <> "" Then Kill strTempFile
    
    intMBID = CInt(Val(Mid(Me.lvwMB.SelectedItem.Key, 2)))
    '读取数据库里面的模板文件
    strSQL = "select MBID,MBContent from SET_BBMB" _
            & " where MBID=" & intMBID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    Call ReadDB(rstemp("MBContent"), strTempFile)
    rstemp.Close
    
    Set WordTemps = New Word.Application
    
    '循环所有选择的客户
    For i = LBound(arrGUID) To UBound(arrGUID)
        '获取当前客户的相反性别
       
        strSQL = "select SEX from SET_GRXX" _
            & " where GUID=" & arrGUID(i)
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If Not rstemp.EOF Then
            intSex = IIf(rstemp("SEX") = "女", 1, 2)
            rstemp.Close
        Else
            intSex = 2 '如果出错，当男性处理
        End If
        
        Set docTemps = WordTemps.Documents.Add(strTempFile, False)
        Set bookColls = docTemps.Bookmarks
        
        For Each bookColl In bookColls
            strBookName = bookColl.name
            strXMID = GetIDFromBookMark(strBookName, True)
            
            If Len(strXMID) >= 2 Then
                strHeader = Left(strXMID, 1) '记录头部标识
                strXMID = Mid(strXMID, 2) '去掉头部
                
                '初始化异常标识
                blnUnnormal = False
                Select Case strHeader
                    '科室名称类
                    Case gtypHeader.KESHI
                        strSQL = "select KSMC from SET_KSSZ" _
                                & " where KSID='" & strXMID & "'"
                    '科室医生类
                    Case gtypHeader.DOCTOR_KESHI
                        strSQL = "select Name from DATA_KSXJ,RY_Employee" _
                                & " where DATA_KSXJ.GUID=" & arrGUID(i) _
                                & " and DATA_KSXJ.KSID='" & strXMID & "'" _
                                & " and DATA_KSXJ.EmployeeID=RY_Employee.EmployeeID"
                    '科室医生签名类
                    Case gtypHeader.DOCTOR_SIGN_KESHI
                        strSQL = "select Sign from DATA_KSXJ,RY_Employee" _
                                & " where DATA_KSXJ.GUID=" & arrGUID(i) _
                                & " and DATA_KSXJ.KSID='" & strXMID & "'" _
                                & " and DATA_KSXJ.EmployeeID=RY_Employee.EmployeeID"
                        GoSub InsertDoctorSign
                    '科室小结类
                    Case gtypHeader.KSXJ
                        strSQL = "select XJValue from DATA_KSXJ where GUID=" & arrGUID(i) _
                                & " and KSID='" & strXMID & "'"
                    '总检结论类
                    Case gtypHeader.ZJJL
                        strSQL = "select JLValue from DATA_ZJJL where GUID=" & arrGUID(i)
                    '总检建议类
                    Case gtypHeader.ZJJY
                        strSQL = "select JYValue from DATA_ZJJY where GUID=" & arrGUID(i)
                    '大项名称类
                    Case gtypHeader.DAXIANG
                        strSQL = "select DXMC from SET_DX" _
                                & " where DXID='" & strXMID & "'"
                    '小项名称类
                    Case gtypHeader.XIAOXIANG
                        strSQL = "select XXMC from SET_XX" _
                                & " where XXID='" & strXMID & "'"
                    '医生类
                    Case gtypHeader.DOCTOR
                        strSQL = "select Name from RY_Employee" _
                                & " where EmployeeID=" & CInt(strXMID)
                    '医生签名类
                    Case gtypHeader.DOCTORSIGN
                        strSQL = "select EmployeeID,Sign from RY_Employee" _
                                & " where EmployeeID=" & CInt(strXMID)
                        GoSub InsertDoctorSign
                        
                    '体检结果类
                    Case gtypHeader.SRESULT '上次体检结果
                           strSQL = "select healthID from Set_GRXX where GUID=" & arrGUID(i)
                           Set rs = New ADODB.Recordset
                           rs.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                           HEALTHID = rs(0)
                           rs.Close