dlgpersonreport.frm

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

'************************************************************************
'被调函数
'参数1：客户的唯一编号
'参数2：主调窗体名
'************************************************************************
Public Sub ShowPersonReport(ByVal lngGUID As Long, ByRef frmOwner As Form)
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim itmTemp As ListItem
    
    If lngGUID <= 0 Then Exit Sub
    '获取当前客户的姓名
    strSQL = "select HealthID,YYRXM from SET_GRXX" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    mlngGUID = lngGUID
    mstrHealthID = rstemp("HealthID")
    mstrName = rstemp("YYRXM")
    Me.Caption = "打印 " & mstrName & " 的报表"
    
    rstemp.Close
    
    '加载所有个人模板
    strSQL = "select MBID,MBMC,MBSM,SFMR from SET_BBMB" _
            & " where MBLX=" & GEREN
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount >= 1 Then
        rstemp.MoveFirst
        Do
            Set itmTemp = Me.lvwMB.ListItems.Add(, "W" & rstemp("MBID"), rstemp("MBMC"))
            itmTemp.SubItems(1) = rstemp("MBSM")
            '是否默认
            If rstemp("SFMR") = True Then
                Set Me.lvwMB.SelectedItem = itmTemp
            End If
            
            rstemp.MoveNext
        Loop Until rstemp.EOF
        rstemp.Close
        
        '如果没有默认选择，则选择第一个模板
        If Me.lvwMB.SelectedItem Is Nothing Then
            Set Me.lvwMB.SelectedItem = Me.lvwMB.ListItems(1)
        End If
        
        cmdExport.Enabled = True
    Else
        cmdExport.Enabled = False
    End If
    
    Me.Show vbModeless, fMainForm
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 strTempPath As String '
    Dim strTempFile As String '模板文件名
    Dim intMBID As Integer
    Dim intCount As Integer '选择的人数
    Dim arrReportFile() As String '每个客户报表存放的文件名
    Dim arrGUID() 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 strSignFile 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
    
    Me.MousePointer = vbHourglass
    
    '是否有模板
    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 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
    '首先获取保存的文件名
    ReDim Preserve arrReportFile(j)
    ReDim Preserve arrGUID(j)
    
    'GUID
    arrGUID(j) = mlngGUID
    '默认文件名
    arrReportFile(j) = strReportPath & Me.lvwMB.SelectedItem.Text & "_" _
            & mstrHealthID & "_" _
            & mstrName & ".doc"
    If chkDefault.Value = 0 Then '如果不采用默认文件名
        arrReportFile(j) = GetFileName(Me.CommonDialog1, "Word文档(*.doc)|*.doc", _
                "客户 “" & mstrName & "” 的报表保存为", arrReportFile(j), WRITEFILE)
        If arrReportFile(j) = "" Then GoTo ExitLab '一旦取消则全部取消
    End If
    
    j = j + 1
    
    '获取临时路径
    strTempPath = String(256, Chr(0))
    Call GetTempPath(256, strTempPath)
    'strip the rest of the buffer
    strTempPath = Left(strTempPath, InStr(strTempPath, Chr(0)) - 1)
    If Right(strTempPath, 1) <> "\" Then
        strTempPath = strTempPath & "\"
    End If
    
    '生成临时模板文件
    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 ColumnToFile(rstemp("MBContent"), strTempFile, rstemp)
    rstemp.Close
    
    Set WordTemps = New Word.Application
    
    '循环所有选择的客户
    For i = LBound(arrGUID) To UBound(arrGUID)
        Set docTemps = WordTemps.Documents.Add(strTempFile, False)
        Set bookColls = docTemps.Bookmarks
        
        For Each bookColl In bookColls
            strBookName = bookColl.name
            GoSub Get_XMID
            
            If Len(strXMID) >= 2 Then
                strHeader = Left(strXMID, 1) '记录头部标识
                
                strXMID = Mid(strXMID, 2) '去掉头部
                '**********************20040523加入 闻***************************
                '为解决在一个WORD文件里不能有多处使用同一个名字的书签的问题,在这里取真正的项目ID
                If InStr(1, strXMID, "A") > 1 Then
                    strXMID = Mid(strXMID, 1, InStr(1, strXMID, "A") - 1)
                End If
                '**********************20040523加入 闻***************************
                Select Case strHeader
                    Case gtypHeader.KESHI
                        strSQL = "select KSMC from SET_KSSZ" _
                                & " where KSID='" & strXMID & "'"
                    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)
                        Set rstemp = New ADODB.Recordset
                        rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                        
                        If Not IsNull(rstemp("Sign")) Then
                            strSignFile = GetTempPathW & "Sign.jpg"
                            If Dir(strSignFile) <> "" Then Kill strSignFile
                            If ColumnToFile(rstemp("Sign"), strSignFile, rstemp) = True Then
                                '插入图片文件到Word文档中
                                bookColl.Range.InlineShapes.AddPicture FileName:=strSignFile, _
                                        LinkToFile:=False, SaveWithDocument:=True
                            End If
                            
                            rstemp.Close
                        End If
                        strSQL = ""
                    '体检结果类
                    Case gtypHeader.RESULT
                        If Len(strXMID) = 7 Then '小项
                            '首先获取该项目所属大项的名称
                            strSQL = "select DXPYSX,XXPYSX from SET_XX,SET_ZH_Data,SET_DX" _
                                    & " where SET_XX.XXID='" & strXMID & "'" _
                                    & " and SET_XX.XXID=SET_ZH_Data.XXID" _
                                    & " and SET_ZH_Data.DXID=SET_DX.DXID" _
                                    & " and SET_DX.DXID in (" _
                                        & "select DXID from YY_SJDJDX" _
                                        & " where GUID=" & arrGUID(i) _
                                    & ")"
                            Set rstemp = New ADODB.Recordset
                            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                            blnGetResult = False
                            If rstemp.RecordCount > 0 Then
                                rstemp.MoveFirst
                                
                                For j = 1 To rstemp.RecordCount
                                    If IsNull(rstemp("DXPYSX")) Or IsNull(rstemp("XXPYSX")) Then
                                        strSQL = ""