📄 frmdwtjbgdc.frm
字号:
arrDMValue(K) = strTemp
End If
Next K
DoEvents
'只需要前10名
If j > 10 Then Exit For
Next j
ElseIf K = 2 Then
'只有一例，无需排序
intPeople = arrIllPeople(1)
End If
If intPeople <> 0 Then '说明在前面经历了排序，也即说明有数据
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 = " "
If j >= 10 Then Exit For '这行代码似乎没有必要
Next j
'设置行标题
' .Cells(2, 1).Value = "例数"
End With
strTitle = "排列前十位的异常体征" '设置图表标题
'图表格式
' xlType = xlPie '饼图
' xlType = xlCylinderColClustered '簇状柱形圆柱图
xlType = xlCylinderColStacked '堆积柱形圆柱图
strYTitle = "百分比%"
blnHaveSeries = True '有系列轴
GoSub SetGraphProperty
End If
End If
strSQL = ""
'***************************************************************
' 所有异常指征及人员名单（表格）
'***************************************************************
Case gtypTuanti.UnnormalTitleAndPersonInTable
'获取保存异常指征的表名
strTempTable = GetYXHZTableOfTT(arrYYID(i))
'是否成功
If strTempTable <> "" Then
strSQL = "select 项目,名单,人数,[百分比%],提示" _
& " from " & strTempTable _
& " order by GUID"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
If Not rstemp.EOF Then
'创建Word表格
lngNumRows = rstemp.RecordCount + 1 '行数（包含标题行）
lngNumCols = rstemp.Fields.Count '列数
GoSub SetTableObject
With oTable
'行标题
.Cell(1, 1).Range.Text = "项目"
.Cell(1, 2).Range.Text = "名单"
.Cell(1, 3).Range.Text = "人数"
.Cell(1, 4).Range.Text = "百分比%"
.Cell(1, 5).Range.Text = "提示"
'循环赋值
For lngCurrRow = 1 To rstemp.RecordCount
For lngCurrCol = 1 To rstemp.Fields.Count
.Cell(lngCurrRow + 1, lngCurrCol).Range.Text = rstemp(lngCurrCol - 1) & ""
Next lngCurrCol
rstemp.MoveNext
Next lngCurrRow
End With
End If
strSQL = "" '清除该变量，便于后面不再提交查询
End If
'***************************************************************
' 所有异常指征不含人员名单
'***************************************************************
Case gtypTuanti.UnnormalTitleNoPerson
strPrint = GetProblem(arrYYID(i), 1)
'***************************************************************
' 所有异常指征、人员名单，以及相应健康建议
'***************************************************************
Case gtypTuanti.UnnormalTitleAandPersonWithSuggest
strPrint = GetProblem(arrYYID(i), 2)
Case gtypTuanti.HEALTH_STATUS
If gblnIsSpy Then
On Error Resume Next
strSQL = "select * from SET_HEALTH" _
& " order by HealthID"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
If Err.Number <> 0 Then
Err.Clear
Else
If Not rstemp.EOF Then
GoSub SetGraphObject
ReDim arrIllPeople(1 To rstemp.RecordCount)
ReDim strHealthName(1 To rstemp.RecordCount)
For j = 1 To rstemp.RecordCount
strHealthName(j) = rstemp("HealthName")
arrIllPeople(j) = GetHealthStatusPersons(arrYYID(i), rstemp("HealthID"))
rstemp.MoveNext
Next j
With oChart.Application.DataSheet
For j = LBound(arrIllPeople) To UBound(arrIllPeople)
.Cells(1, j + 1).Value = strHealthName(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
strTitle = "健康状况" '设置图表标题
'图表格式
xlType = xlCylinderColStacked '堆积柱形圆柱图
strYTitle = "百分比%"
blnHaveSeries = True '有系列轴
GoSub SetGraphProperty
rstemp.Close
End If
End If
End If
On Error GoTo ErrMsg
strSQL = ""
Case gtypTuanti.HEALTH_STATUS_GRADE
'
End Select
End Select
'提交查询
If strSQL <> "" Then
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rstemp.RecordCount > 0 Then
strPrint = rstemp(0) & ""
rstemp.Close
Else
strPrint = ""
End If
'清除
strSQL = ""
End If
'写入标签位置
If strPrint <> "" Then
bookColl.Range.Text = strPrint
'清除
strPrint = ""
End If
End If
Next
'保存报表文件
Call SaveWordDocument(WordTemps, docTemps, arrReportFile(i))
If chkPrintImmediate.Value = vbChecked Then
Call PrintWordDocument(WordTemps, arrReportFile(i))
End If
docTemps.Close
DoEvents
End If
Next i
'清除缓冲区
Erase arrYYID
Erase arrReportFile
MsgBox "导出完毕！", vbInformation, "提示"
GoTo ExitLab
'创建Graph对象：
SetGraphObject:
Set oShape = bookColl.Range.InlineShapes.AddOLEObject( _
ClassType:="MSGraph.Chart.8", FileName:="", _
LinkToFile:=False, DisplayAsIcon:=False)
Set oChart = oShape.OLEFormat.Object
DoEvents
With oChart.Application.DataSheet
'清除默认数据
.Range("00:G" & oChart.SeriesCollection.Count).Clear
'清除行
Do While oChart.SeriesCollection.Count >= 1
oChart.SeriesCollection(oChart.SeriesCollection.Count).Delete
Loop
'清除列
For j = Asc("G") To Asc("A") - 1 Step -1
.Range(Chr(j)).Delete
Next j
End With
DoEvents
Return
'设置Graph对象的公用属性
SetGraphProperty:
oChart.Application.Chart.ChartType = xlType '指定图表形状
If oChart.Application.DataSheet.Cells(2, 2) <> "" Then
'分类轴标题
With oChart.Application.Chart.Axes(xlCategory)
.HasTitle = False '不显示分类轴
End With
'系列轴
If blnHaveSeries Then
With oChart.Application.Chart.Axes(xlSeries)
' .HasTitle = True
' With .AxisTitle
' .Caption = strYTitle
' .Font.name = "宋体"
' .Font.Size = 10
' End With
End With
End If
'数值轴标题
If Not blnHaveSeries Then '有系列轴时不显示数值轴标题，这是为了增加显示空间
With oChart.Application.Chart.Axes(xlValue)
.HasTitle = True
.AxisTitle.Text = strYTitle
With .AxisTitle
' .Font.NAME = "宋体"
' .Font.Size = 11
' .Caption = strYTitle
End With
End With
End If
With oChart.Application.Chart
.HasLegend = False '不显示图例
.ChartArea.Font.name = "宋体"
.ChartArea.Font.Size = 10
'指定图表的标题
' .HasTitle = True
' .ChartTitle.Text = strTitle
End With
End If
' oChart.Axis(VtChAxisIdZ).Labels(1).Auto = False
oChart.Application.Update '更新
oChart.Application.Quit '退出Graph对象
'... If desired, you can proceed from here using the Microsoft Graph
'Object model on the oChart object to make additional changes to the
'chart.
oShape.Width = docTemps.PageSetup.PageWidth - (docTemps.PageSetup.LeftMargin + docTemps.PageSetup.RightMargin) 'oWord.InchesToPoints(6.25)
oShape.Height = oShape.Width * 2 / 3 'oWord.InchesToPoints(3.57)
Set oChart = Nothing
DoEvents
Return '返回
'创建Table对象：
SetTableObject:
Set oTable = bookColl.Range.Tables.Add(Range:=bookColl.Range, _
NumRows:=lngNumRows, NumColumns:=lngNumCols, _
DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed)
With oTable
If .Uniform = False Then
'1、3、4、5列居中显示
For j = 1 To lngNumCols
.Cell(Row:=1, Column:=j).Select
Selection.SelectColumn
Selection.SelectCell
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
' If j <> 2 Then
' '水平方向居中
' Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
' Else
' '水平方向居左
' Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
' End If
' '垂直方向居中
' Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
Next j
'第一行居中显示
.Cell(Row:=1, Column:=j).Select
Selection.SelectRow
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End If
End With
Return
ErrMsg:
Status = SetError(Err.Number, Err.Description, Err.Source)
ErrMsg Status
ExitLab:
On Error Resume Next
Erase arrReportFile
Erase arrYYID
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -