📄 frmdwbhhzdc.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "ComDlg32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{0B81E4A9-BE4E-4AEF-9272-33AB5B51C6FC}#1.0#0"; "XPControls.ocx"
Begin VB.Form FrmDWBHHZDC
BackColor = &H80000018&
BorderStyle = 1 'Fixed Single
Caption = "单位病患汇总导出"
ClientHeight = 6495
ClientLeft = 45
ClientTop = 330
ClientWidth = 9240
Icon = "FrmDWBHHZDC.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6495
ScaleWidth = 9240
StartUpPosition = 2 'CenterScreen
Begin XPControls.XPCommandButton cmdOK
Height = 435
Left = 2550
TabIndex = 0
Top = 5850
Width = 1185
_ExtentX = 2090
_ExtentY = 767
Caption = "导出到写字板"
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
Begin XPControls.XPCommandButton cmdExit
Height = 435
Left = 5310
TabIndex = 1
Top = 5850
Width = 1185
_ExtentX = 2090
_ExtentY = 767
Caption = "退出"
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
Begin MSComctlLib.ListView LvwDWei
Height = 5505
Left = 120
TabIndex = 2
Top = 60
Width = 5925
_ExtentX = 10451
_ExtentY = 9710
View = 2
LabelWrap = -1 'True
HideSelection = 0 'False
AllowReorder = -1 'True
FullRowSelect = -1 'True
GridLines = -1 'True
_Version = 393217
ForeColor = 12582912
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 = 3
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "预约ID"
Object.Width = 2469
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "单位名称"
Object.Width = 5292
EndProperty
BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 2
Text = "体检日期"
Object.Width = 2540
EndProperty
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 150
Top = 4620
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin MSComctlLib.TreeView tvwXMu
Height = 5460
Left = 6180
TabIndex = 7
Top = 90
Width = 2925
_ExtentX = 5159
_ExtentY = 9631
_Version = 393217
HideSelection = 0 'False
LabelEdit = 1
Style = 7
Checkboxes = -1 'True
Appearance = 1
End
Begin VB.Frame Frame3
Appearance = 0 'Flat
BackColor = &H80000018&
ForeColor = &H80000008&
Height = 495
Left = 2100
TabIndex = 3
Top = 2940
Width = 3375
Begin VB.OptionButton optMale
BackColor = &H80000018&
Caption = "男"
Height = 255
Left = 1365
TabIndex = 6
Top = 180
Width = 795
End
Begin VB.OptionButton optNNTY
BackColor = &H80000018&
Caption = "所有"
Height = 255
Left = 240
TabIndex = 5
Top = 180
Value = -1 'True
Width = 795
End
Begin VB.OptionButton optFemale
BackColor = &H80000018&
Caption = "女"
Height = 255
Left = 2490
TabIndex = 4
Top = 180
Width = 795
End
End
End
Attribute VB_Name = "FrmDWBHHZDC"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim arrYYID() As String
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdOK_Click()
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim strTemp As String
Dim strSelect As String
Dim strTJ As String
Dim strCondition As String
Dim strKSMC As String
Dim rsTemp As ADODB.Recordset
Dim rsHZ As ADODB.Recordset
Dim nodTemp As Node
Dim strYYID As String
Dim intCount As Integer '当前选择单位的总人数
Dim intUnnormalCount As Integer '非正常人数
Dim strSummary As String '体检综述
Dim strSuggest As String '体检建议
Dim strTempSuggest As String '某各项目里面的建议
Dim strJYMC As String '要查询的症状
Dim intIndex As Integer '当前处理项目的序号
Dim f As Integer '文件号
Dim strDXPYSX As String
Dim strXXPYSX As String
Dim intType As Integer
Dim strXMID As String
Dim strXMMC As String '当前处理项目的名称
Dim strFileName As String
Dim i As Integer, j As Integer, l As Integer
Dim arrKSMC() As String
Dim blnHave As Boolean
Dim blnSel As Boolean
Me.MousePointer = vbHourglass
If lvwDWei.SelectedItem Is Nothing Then
MsgBox "请选择要导出的单位！", vbInformation, "提示"
GoTo ExitLab
End If
'获取文件名
strFileName = GetFileName(Me.CommonDialog1, "文本文档（*.txt）|*.txt", _
"另存为", lvwDWei.SelectedItem.SubItems(1) & "_病患汇总导出.txt", WRITEFILE)
If strFileName = "" Then GoTo ExitLab
'查询当前单位选择的科室
blnSel = False
l = 0
For i = 1 To tvwXMu.Nodes.Count
If Len(tvwXMu.Nodes(i).Key) = 3 Then '科室
blnHave = False
For j = 1 To tvwXMu.Nodes.Count
Set nodTemp = tvwXMu.Nodes(j)
If Len(nodTemp.Key) = 12 Then '小项
If (nodTemp.Parent.Parent Is tvwXMu.Nodes(i)) And nodTemp.Checked = True Then
blnHave = True
ReDim Preserve arrKSMC(l)
arrKSMC(l) = tvwXMu.Nodes(i).Text
End If
End If
If blnHave = True Then
l = l + 1
blnSel = True
Exit For '跳出第一层循环
End If
Next j
End If
Next i
If blnSel = False Then
MsgBox "请选择要汇总的项目！", vbInformation, "提示"
GoTo ExitLab '没有选择科室
End If
'记录当前选择单位的预约编号
strYYID = lvwDWei.SelectedItem.Text
'获取当前单位的总人数
strSQL = "select Count(*) from SET_GRXX" _
& " where YYID='" & strYYID & "'"
Set rsTemp = New ADODB.Recordset
rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
intCount = rsTemp(0)
rsTemp.Close
If intCount < 1 Then
MsgBox "当前单位“" & lvwDWei.SelectedItem.SubItems(1) & "”没有人员参加体检，无从导出！，", vbInformation, "提示"
GoTo ExitLab
End If
'******************************************************************
'写入题头
'******************************************************************
strSummary = "单位体检阳性指征名单：" & vbCrLf
strSuggest = "症状分析及建议：" & vbCrLf
'******************************************************************
'写入详细信息
'******************************************************************
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -