📄 frmdwtjbgdc.frm
字号:
If strReportPath = "" Then GoTo ExitLab
If Right(strReportPath, 1) <> "\" Then
strReportPath = strReportPath & "\"
End If
End If
j = 0
'首先获取保存的文件名
For i = 1 To Me.LvwDWei.ListItems.Count
If Me.LvwDWei.ListItems(i).Selected = True Then
ReDim Preserve arrReportFile(j)
ReDim Preserve arrYYID(j)
'YYID
arrYYID(j) = Me.LvwDWei.ListItems(i).Text
'默认文件名
arrReportFile(j) = strReportPath & Me.lvwMB.SelectedItem.Text & "_" _
& Me.LvwDWei.ListItems(i).SubItems(1) & "_" _
& Me.LvwDWei.ListItems(i).SubItems(2) & ".doc"
If chkDefault.Value = 0 Then '如果不采用默认文件名
arrReportFile(j) = GetFileName(Me.CommonDialog1, "Word文档(*.doc)|*.doc", _
"客户 “" & Me.LvwDWei.ListItems(i).SubItems(1) & "” 的报表保存为", _
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 ColumnToFile(rstemp("MBContent"), strTempFile, rstemp)
rstemp.Close
Set WordTemps = New Word.Application
'循环所有选择的客户
For i = LBound(arrYYID) To UBound(arrYYID)
'检查当前单位是否有已总检人员
If GetPersonCheckStatus(FINISHED, arrYYID(i)) < 1 Then
MsgBox LvwDWei.FindItem(arrYYID(i), lvwTag).SubItems(1) _
& " 不存在已做总检的人员，无法实现团检报告导出！", _
vbInformation, "提示"
Else
Set docTemps = WordTemps.Documents.Add(strTempFile, False)
Set bookColls = docTemps.Bookmarks
'首先获取当前单位已体检总人数
intTotalOfAlreadyCheck = GetDWYTJRS(arrYYID(i))
'循环处理所有书签
For Each bookColl In bookColls
strBookName = bookColl.name
strXMID = GetIDFromBookMark(strBookName)
If Len(strXMID) >= 2 Then
strHeader = Left(strXMID, 1) '记录头部标识
strXMID = Mid(strXMID, 2) '去掉头部
blnHaveSeries = False '默认为没有系列轴
Select Case strHeader
'科室异常类
'***************************************************************
' 科室异常（图）
'***************************************************************
Case gtypHeader.KESHIYICHANG
'首先取得科室名称
strSQL = "select KSMC from SET_KSSZ" _
& " where KSID='" & strXMID & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
If rstemp.RecordCount > 0 Then
'设置图表标题
strTitle = rstemp("KSMC") & " 异常的类型和例数"
rstemp.Close
strSQL = "select JYDMID,DMValue from DM_ZJJY" _
& " where KSID='" & strXMID & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rstemp.RecordCount > 0 Then
K = 1
For j = 1 To rstemp.RecordCount
intPeople = GetNormalRS(arrYYID(i), "", "JYDMID", rstemp("JYDMID"))
If intPeople > 0 Then
ReDim Preserve arrIllPeople(1 To K)
ReDim Preserve arrDMValue(1 To K)
arrIllPeople(K) = intPeople
arrDMValue(K) = rstemp("DMValue")
K = K + 1
End If
DoEvents
rstemp.MoveNext
Next j
rstemp.Close
If K > 1 Then '说明在前面经历了For循环，也即说明有数据
GoSub SetGraphObject
With oChart.Application.DataSheet
For j = LBound(arrIllPeople) To UBound(arrIllPeople)
.Cells(1, j + 1).Value = arrDMValue(j) & arrIllPeople(j) & "人" '列标题
.Cells(j + 1, j + 1).Value = GetRatio(arrIllPeople(j), intTotalOfAlreadyCheck, , False)
.Cells(j + 1, 1).Value = " "
Next j
'设置行标题
' .Cells(2, 1).Value = "例数"
End With
'图表格式
' xlType = xl3DPieExploded '三维分离型饼图
' xlType = xlCylinderColClustered '簇状柱形圆柱图
xlType = xlCylinderColStacked '堆积柱形圆柱图
strYTitle = "百分比%"
blnHaveSeries = True '有系列轴
GoSub SetGraphProperty
End If
End If
End If
strSQL = ""
'医生类
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.OTHER
Select Case strXMID
Case gtypTemplateID.DYRQ '打印日期
strPrint = CStr(Date)
Case gtypTemplateID.DWMC '单位名称
strSQL = "select DWMC from SET_DW,YY_TJDJ" _
& " where SET_DW.DWID=YY_TJDJ.DWID" _
& " and YY_TJDJ.YYID='" & arrYYID(i) & "'"
End Select
'团体类
Case gtypHeader.TUANTI
Select Case strXMID
Case gtypTuanti.PROBLEM '健康问题列表
strPrint = GetProblem(arrYYID(i), 0)
'***************************************************************
' 各年龄段的体检人数（图）
'***************************************************************
Case gtypTuanti.AGEGROUP '
'在Word中插入Graph图表
GoSub SetGraphObject
With oChart.Application.DataSheet
'按年龄段设置图表
For j = 1 To 6
Select Case j
Case 1
intBegin = 0
intStop = 24
strColTitle = "<25岁"
Case 2
intBegin = 25
intStop = 30
strColTitle = "25～30岁"
Case 3
intBegin = 31
intStop = 40
strColTitle = "31～40岁"
Case 4
intBegin = 41
intStop = 50
strColTitle = "41～50岁"
Case 5
intBegin = 51
intStop = 60
strColTitle = "51～60岁"
Case 6
intBegin = 60
intStop = 200
strColTitle = ">60岁"
End Select
'获取不同年龄段的客户
strTemp = GetTJRSByAge(arrYYID(i), intBegin, intStop)
intMale = CInt(Left(strTemp, InStr(1, strTemp, ",") - 1))
intFemale = CInt(Mid(strTemp, InStr(1, strTemp, ",") + 1))
.Cells(1, j + 1).Value = strColTitle '列标题
.Cells(2, j + 1).Value = intMale
.Cells(3, j + 1).Value = intFemale
Next j
'设置行标题
.Cells(2, 1).Value = "男"
.Cells(3, 1).Value = "女"
End With
strTitle = "各年龄段的体检人数" '设置图表标题
'图表格式
xlType = xl3DColumn '三维柱形图
GoSub SetGraphProperty
'***************************************************************
' 各科室异常体征（图）
'***************************************************************
Case gtypTuanti.KESHIYICHANG '各科室异常体征（图）
strSQL = "select KSID,KSMC from SET_KSSZ" _
& " order by SXH"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rstemp.RecordCount > 0 Then
GoSub SetGraphObject
With oChart.Application.DataSheet
K = 2
For j = 1 To rstemp.RecordCount
intPeople = GetNormalRS(arrYYID(i), "", "KSID", rstemp("KSID"))
If intPeople > 0 Then '只显示有异常体征的科室
.Cells(1, K).Value = rstemp("KSMC") '列标题
.Cells(2, K).Value = intPeople
K = K + 1
End If
DoEvents
rstemp.MoveNext
Next j
'设置行标题
.Cells(2, 1).Value = "例数"
End With
rstemp.Close
strTitle = "各科室异常体征" '设置图表标题
'图表格式
xlType = xlColumnClustered '簇状柱形图
GoSub SetGraphProperty
End If
strSQL = ""
'***************************************************************
' 排列前十位的异常体征（图）
'***************************************************************
Case gtypTuanti.FRONTTENYICHANG '排列前十位的异常体征（图）
strSQL = "select JYDMID,DMValue from DM_ZJJY"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rstemp.RecordCount > 0 Then
K = 1
For j = 1 To rstemp.RecordCount
intPeople = GetNormalRS(arrYYID(i), "", "JYDMID", rstemp("JYDMID"))
If intPeople > 0 Then
ReDim Preserve arrIllPeople(1 To K)
ReDim Preserve arrDMValue(1 To K)
arrIllPeople(K) = intPeople
arrDMValue(K) = rstemp("DMValue")
K = K + 1
End If
rstemp.MoveNext
Next j
rstemp.Close
intPeople = 0
'对取得的异常体征数进行排序(倒序)
If K > 2 Then '说明至少有两例，需要进行排序
For j = LBound(arrIllPeople) To UBound(arrIllPeople) - 1
For K = j + 1 To UBound(arrIllPeople)
If arrIllPeople(j) < arrIllPeople(K) Then
intPeople = arrIllPeople(j)
strTemp = arrDMValue(j)
arrIllPeople(j) = arrIllPeople(K)
arrDMValue(j) = arrDMValue(K)
arrIllPeople(K) = intPeople
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -