📄 frmbhtj.frm
字号:
EndProperty
End
Begin XPControls.XPCommandButton cmdExit
Height = 375
Left = 2190
TabIndex = 11
Top = 270
Width = 795
_ExtentX = 1402
_ExtentY = 661
Caption = "退出(&X)"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
End
Begin VB.Frame Frame3
BackColor = &H00D3DABC&
Caption = "类别选择"
Height = 705
Left = 120
TabIndex = 4
Top = 90
Width = 3135
Begin VB.OptionButton OptAll
BackColor = &H00D3DABC&
Caption = "全部"
Height = 285
Left = 210
TabIndex = 7
Top = 300
Width = 675
End
Begin VB.OptionButton OptJB
BackColor = &H00D3DABC&
Caption = "疾病"
Height = 285
Left = 1110
TabIndex = 6
Top = 300
Width = 735
End
Begin VB.OptionButton OptCJB
BackColor = &H00D3DABC&
Caption = "常见病"
Height = 285
Left = 2040
TabIndex = 5
Top = 300
Width = 855
End
End
Begin VB.Frame Frame4
BackColor = &H00D3DABC&
Caption = "体检时间"
Height = 675
Left = 8340
TabIndex = 0
Top = 810
Width = 3435
Begin MSComCtl2.DTPicker dtpStart
Height = 345
Left = 120
TabIndex = 1
Top = 240
Width = 1365
_ExtentX = 2408
_ExtentY = 609
_Version = 393216
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Format = 158138369
CurrentDate = 37987
MaxDate = 73415
MinDate = 36526
End
Begin MSComCtl2.DTPicker dtpEnd
Height = 345
Left = 1980
TabIndex = 2
Top = 240
Width = 1335
_ExtentX = 2355
_ExtentY = 609
_Version = 393216
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Format = 158138369
CurrentDate = 37987
MaxDate = 73415
MinDate = 36526
End
Begin VB.Label Label2
BackStyle = 0 'Transparent
Caption = "至"
Height = 285
Index = 2
Left = 1620
TabIndex = 3
Top = 300
Width = 255
End
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 960
Top = 6930
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin MSComctlLib.ListView lvwBH
Height = 7095
Left = 120
TabIndex = 14
Top = 1260
Width = 3135
_ExtentX = 5530
_ExtentY = 12515
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = -1 'True
Checkboxes = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = 12648384
BorderStyle = 1
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
NumItems = 1
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "病患名称"
Object.Width = 5292
EndProperty
End
End
Attribute VB_Name = "FrmBHTJ"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim arrYYID()
Dim arrFZ()
Dim mstrYYID As String
Dim mstrFZID As String
Dim mstrJYDMID As String
Dim mstrDWMC As String
Dim mintTotal As Integer
Dim mstrBHMC As String
Dim arrGUID()
Dim mintlvPXFC As Integer '标识lvwRY的排序方式,0为升序,1为降序
Dim mintSex As Integer
Dim mintFromAge As Integer
Dim mintToAge As Integer
Private Sub ChkNone_Click()
Dim i As Integer
If ChkNone.Value = vbChecked Then
ChkTotal.Value = vbUnchecked
For i = 1 To Me.lvwBH.ListItems.Count
lvwBH.ListItems(i).Checked = False
Next i
End If
End Sub
Private Sub ChkTotal_Click()
Dim i As Integer
If ChkTotal.Value = vbChecked Then
ChkNone.Value = vbUnchecked
For i = 1 To Me.lvwBH.ListItems.Count
lvwBH.ListItems(i).Checked = True
Next i
End If
End Sub
Private Sub CmbTJDW_Click()
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim rstemp As ADODB.Recordset
Dim i As Integer
CmbFZ.Clear
If CmbTJDW.Text <> "" Then '说明属于团体客户
'在CmbFZ中显示该单位当前的分组
strSQL = "select FZID,FZMC from FZ_FZSY" _
& " where YYID='" & arrYYID(CmbTJDW.ListIndex) & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
If rstemp.RecordCount > 0 Then
ReDim arrFZ(rstemp.RecordCount)
rstemp.MoveFirst
i = 1
Do While Not rstemp.EOF
CmbFZ.AddItem rstemp.Fields("FZMC")
' CmbFZ.ItemData(CmbFZ.NewIndex) = rsTemp("FZID")
arrFZ(i) = rstemp.Fields("FZID")
rstemp.MoveNext
i = i + 1
Loop
rstemp.Close
Else
'前面已经清空
CmbFZ.Clear
End If
End If
Exit Sub
ErrMsg:
Status = SetError(Err.Number, Err.Description, Err.Source)
ErrMsg Status
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdExport_Click()
Dim strFileName As String
If CmbTJDW.Text = "" Then
MsgBox "请选择体检团体", , "提示"
Exit Sub
End If
strFileName = GetFileName(Me.CommonDialog1, "文本文档（*.txt）|*.txt", "另存为", _
CmbTJDW.Text & "_病患汇总导出.txt", WRITEFILE)
If strFileName = "" Then GoTo ExitLab
If TxtResult.Text = "" Then
cmdQuery_Click
End If
'将图表保存为图片文件(可用)
' MSChart1.ChartType = VtChChartType3dBar
' MSChart1.EditCopy
' SavePicture Clipboard.GetData(), "e:\sss.bmp"
If WriteTextFile(strFileName, TxtResult.Text) Then
'用记事本打开文件
' Shell "Notepad.exe " & strFileName, vbNormalFocus
Call Shell(gstrCurrPath & "wordpad.exe " & Chr(34) & strFileName, vbNormalFocus)
End If
ExitLab:
'
End Sub
Private Sub BHHZtoTxtBHHZ()
Dim strSQL As String
Dim rstemp As ADODB.Recordset
Dim rsFZ As ADODB.Recordset
Dim i As Integer
Dim strResult As String
Dim tmpCount As Integer
Dim strTmpHZContent As String
Dim strBFB As String
Dim lngPersonCount As Long
'首先查出该团体中已体检的共有多少人
strSQL = "select Count(*) from SET_GRXX"
Set rsFZ = New ADODB.Recordset
If CmbFZ.ListIndex = -1 Then
strSQL = "select count(*) from FZ_FZSJ where (SFTJ=2 or SFTJ=1) and FZID in" _
& " (select FZID from FZ_FZSY where YYID='" & arrYYID(CmbTJDW.ListIndex) & "')" _
& " and YYID='" & arrYYID(CmbTJDW.ListIndex) & "'"
Else
strSQL = "select count(*) from FZ_FZSJ where (SFTJ=2 or SFTJ=1) and FZID=" & arrFZ(CmbFZ.ListIndex + 1) & " and FZID in" _
& " (select FZID from FZ_FZSY where YYID='" & arrYYID(CmbTJDW.ListIndex) & "')" _
& " and YYID='" & arrYYID(CmbTJDW.ListIndex) & "'"
End If
strSQL = strSQL & " and GUID in("
'体检日期
strSQL = strSQL & "select GUID from SET_GRXX" _
& " where YYID='" & arrYYID(CmbTJDW.ListIndex) & "'" _
& " and SET_GRXX.TJRQ between '" _
& dtpStart.Value & "' and '" & dtpEnd.Value & "'"
'性别
Select Case mintSex
Case 0
'
Case 1
strSQL = strSQL & " and SET_GRXX.SEX='男'"
Case 2
strSQL = strSQL & " and SET_GRXX.SEX='女'"
End Select
'年龄
strSQL = strSQL & " and SET_GRXX.AGE between " & mintFromAge & " and " & mintToAge
strSQL = strSQL & ")"
rsFZ.Open strSQL, GCon, adOpenStatic, adLockReadOnly
mintTotal = rsFZ(0)
'查询单位名称
strSQL = "select SET_DW.*,YY_TJDJ.* from SET_DW,YY_TJDJ where SET_DW.DWID=YY_TJDJ.DWID and YYID='" & arrYYID(CmbTJDW.ListIndex) & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
If CmbFZ.ListIndex = -1 Then
strResult = strResult & "单位" & rstemp("DWMC") & " 在" & dtpStart.Value & " 至" & dtpEnd.Value _
& " 内已体检 " & mintTotal & " 人" & vbCrLf & vbCrLf
Else
strResult = strResult & "单位" & rstemp("DWMC") & " 的分组 " & CmbFZ.Text & " 在" & dtpStart.Value & " 至" & dtpEnd.Value _
& " 内已体检 " & mintTotal & " 人" & vbCrLf & vbCrLf
End If
For i = 1 To lvwBH.ListItems.Count
'如果该病患列入了统计范围
If lvwBH.ListItems.item(i).Checked = True Then
mstrYYID = arrYYID(CmbTJDW.ListIndex)
mstrJYDMID = Mid(lvwBH.ListItems(i).Key, 2)
mstrBHMC = lvwBH.ListItems(i)
If CmbFZ.ListIndex = -1 Then
mstrFZID = ""
Else
mstrFZID = arrFZ(CmbFZ.ListIndex + 1)
End If
strTmpHZContent = GetContent(lngPersonCount, mstrYYID, mstrFZID, mstrJYDMID, _
dtpStart.Value, dtpEnd.Value, mintSex, mintFromAge, mintToAge)
If mintTotal > 0 Then
strBFB = CStr((lngPersonCount / mintTotal) * 100)
If InStr(1, strBFB, ".") >= 1 Then
strBFB = Left(strBFB, InStr(1, strBFB, ".") + 2)
End If
If Left(strBFB, 1) = "." Then
strBFB = "0" & strBFB
End If
Else
strBFB = 0
End If
If CmbFZ.ListIndex = -1 Then
strResult = strResult & " " & lvwBH.ListItems(i) & " (共" & lngPersonCount & "人,占已体检总人数的" & strBFB & "%) 名单:" _
& vbCrLf & strTmpHZContent & vbCrLf
Else
strResult = strResult & " " & lvwBH.ListItems(i) & " (共" & lngPersonCount & "人,占该分组已体检总人数的" & strBFB & "%) 名单:" _
& vbCrLf & strTmpHZContent & vbCrLf
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -