📄 frmkssz.frm
字号:
VERSION 5.00
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 FrmKSSZ
BackColor = &H80000018&
Caption = "设置科室"
ClientHeight = 7080
ClientLeft = 2625
ClientTop = 1440
ClientWidth = 9600
Icon = "FrmKSSZ.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MDIChild = -1 'True
ScaleHeight = 7080
ScaleWidth = 9600
Begin VB.Frame Frame2
Appearance = 0 'Flat
BackColor = &H80000018&
ForeColor = &H80000008&
Height = 1695
Left = 3840
TabIndex = 18
Top = 5160
Width = 5385
Begin XPControls.XPCommandButton CmdExit
Height = 375
Left = 3540
TabIndex = 11
Top = 990
Width = 1215
_ExtentX = 2143
_ExtentY = 661
Caption = "退出"
Font = "FrmKSSZ.frx":0CCA
End
Begin XPControls.XPCommandButton CmdOK
Height = 375
Left = 2100
TabIndex = 10
Top = 990
Visible = 0 'False
Width = 1215
_ExtentX = 2143
_ExtentY = 661
Caption = "确定"
Font = "FrmKSSZ.frx":0CF6
End
Begin XPControls.XPCommandButton CmdSave
Height = 375
Left = 660
TabIndex = 9
Top = 990
Width = 1215
_ExtentX = 2143
_ExtentY = 661
Caption = "保存"
Font = "FrmKSSZ.frx":0D22
End
Begin XPControls.XPCommandButton CmdDel
Height = 375
Left = 2100
TabIndex = 7
Top = 390
Width = 1215
_ExtentX = 2143
_ExtentY = 661
Caption = "删除"
Font = "FrmKSSZ.frx":0D4E
End
Begin XPControls.XPCommandButton CmdAdd
Height = 375
Left = 660
TabIndex = 6
Top = 390
Width = 1215
_ExtentX = 2143
_ExtentY = 661
Caption = "添加"
Font = "FrmKSSZ.frx":0D7A
End
Begin XPControls.XPCommandButton CmdChange
Height = 375
Left = 3540
TabIndex = 8
Top = 390
Width = 1215
_ExtentX = 2143
_ExtentY = 661
Caption = "修改"
Font = "FrmKSSZ.frx":0DA6
End
End
Begin VB.Frame Frame1
Appearance = 0 'Flat
BackColor = &H80000018&
ForeColor = &H80000008&
Height = 4515
Left = 3840
TabIndex = 12
Top = 300
Width = 5385
Begin VB.ComboBox cmbKSSXH
Height = 315
Left = 1200
Style = 2 'Dropdown List
TabIndex = 19
Top = 2130
Width = 1095
End
Begin VB.TextBox TextKSSM
Enabled = 0 'False
Height = 1680
Left = 1200
MultiLine = -1 'True
TabIndex = 5
Top = 2580
Width = 3945
End
Begin VB.TextBox TextKSWBSX
Enabled = 0 'False
Height = 300
Left = 1200
TabIndex = 4
Top = 1680
Width = 3945
End
Begin VB.TextBox TextKSPYSX
Enabled = 0 'False
Height = 300
Left = 1200
TabIndex = 3
Top = 1245
Width = 3945
End
Begin VB.TextBox TextKSMC
Enabled = 0 'False
Height = 300
Left = 1200
TabIndex = 2
Top = 795
Width = 3945
End
Begin VB.TextBox TextKSID
Enabled = 0 'False
Height = 300
Left = 1200
TabIndex = 1
Top = 330
Width = 3945
End
Begin VB.Label Label8
BackStyle = 0 'Transparent
Caption = "显示顺序"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 240
TabIndex = 20
Top = 2175
Width = 855
End
Begin VB.Label Label5
BackStyle = 0 'Transparent
Caption = "五笔缩写"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 240
TabIndex = 17
Top = 1740
Width = 855
End
Begin VB.Label Label4
BackStyle = 0 'Transparent
Caption = "拼音缩写"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 240
TabIndex = 16
Top = 1290
Width = 855
End
Begin VB.Label Label3
BackStyle = 0 'Transparent
Caption = "说明"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 240
TabIndex = 15
Top = 2550
Width = 615
End
Begin VB.Label Label2
BackStyle = 0 'Transparent
Caption = "名称"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 240
TabIndex = 14
Top = 855
Width = 615
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "ID号"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 240
TabIndex = 13
Top = 390
Width = 615
End
End
Begin MSComctlLib.TreeView TreeView1
Height = 6495
Left = 240
TabIndex = 0
Top = 360
Width = 3375
_ExtentX = 5953
_ExtentY = 11456
_Version = 393217
HideSelection = 0 'False
LabelEdit = 1
Style = 3
HotTracking = -1 'True
Appearance = 1
End
End
Attribute VB_Name = "FrmKSSZ"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim rsKS As New ADODB.Recordset
Dim Status As String '当前科室信息是处理查询"READ"或修改"CHANGE"状态
Dim TotalKS As String
Dim KSCount As Integer
Private Sub cmdAdd_Click()
Dim strSQL As String
Dim i As Integer
Dim rsSXH As ADODB.Recordset
If Status = "CHANGE" Then
MsgBox "请先按保存按钮保存当前信息", vbInformation, "提示"
GoTo 100
End If
Status = "ADD"
'清空所有输入项
SetAllInput True
ClearAllInput
cmdAdd.Enabled = False
cmdDel.Enabled = False
cmdChange.Enabled = False
cmdSave.Enabled = True
CmdOK.Enabled = True
TextKSID.Text = GetKSID()
TextKSID.Enabled = False
'构造查询字符串
strSQL = "select SXH from SET_SXH" _
& " where SXH not in (" _
& "select SXH from SET_KSSZ)"
'打开记录集
Set rsSXH = New ADODB.Recordset
rsSXH.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'清空可能存在的显示
cmbKSSXH.Clear
For i = 1 To rsSXH.RecordCount
cmbKSSXH.AddItem rsSXH("SXH")
rsSXH.MoveNext
Next
If rsSXH.RecordCount > 0 Then
cmbKSSXH.ListIndex = 0
rsSXH.Close
Else
MsgBox "添加的同级项目数已经达到最大，请删除掉一部分项目后再添加！", vbInformation, "提示"
cmdExit_Click
End If
Set rsSXH = Nothing
rsKS.Open "SELECT * FROM set_KSSZ", GCon, adOpenDynamic, adLockOptimistic
rsKS.AddNew
100
End Sub
Private Sub CmdDel_Click()
Dim strSQL As String
Dim rsTemp As ADODB.Recordset
If TreeView1.SelectedItem Is Nothing Then
MsgBox "请在左边的树型控件中选择一个项目！", vbInformation, "提示"
Exit Sub
End If
If Status = "CHANGE" Then
MsgBox "请先按保存按钮保存当前科室信息", vbInformation, "提示"
Else
If MsgBox("该操作不可恢复！" & vbCrLf & "确实要删除科室“" _
& TreeView1.SelectedItem.Text & "”吗？", _
vbQuestion + vbYesNo + vbDefaultButton2, "警告") = vbNo Then Exit Sub
'判断该科室下面是否还有大项，如果有，则禁止删除
strSQL = "select Count(*) from SET_DX" _
& " where KSID='" & TextKSID.Text & "'"
Set rsTemp = New ADODB.Recordset
rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
If rsTemp(0) >= 1 Then
MsgBox "该科室下还有大项存在，无法删除！" & vbCrLf _
& "您可以到“体检项目”里面先删除大项，然后才能删除该科室！", _
vbInformation, "警告"
Exit Sub
End If
If TextKSID.Text <> "" Then
rsKS.Open "SELECT * FROM SET_KSSZ WHERE KSID=" & "'" & TextKSID.Text & "'", GCon, adOpenDynamic, adLockOptimistic
rsKS.Delete adAffectCurrent
rsKS.Close
KSCount = 1
ClearAllInput
DrawNode
End If
End If
End Sub
Private Sub cmdOK_Click()
If Status = "CHANGE" Then
MsgBox "请按保存按钮保存当前科室信息", vbInformation, "提示"
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -