📄 frmjbjywh.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"
Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "TABCTL32.OCX"
Begin VB.Form frmJBJYWH
BorderStyle = 3 'Fixed Dialog
Caption = "建议维护"
ClientHeight = 6960
ClientLeft = 45
ClientTop = 330
ClientWidth = 9540
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6960
ScaleWidth = 9540
ShowInTaskbar = 0 'False
StartUpPosition = 2 'CenterScreen
Begin TabDlg.SSTab SSTab1
Height = 6915
Left = 0
TabIndex = 0
Top = 0
Width = 9495
_ExtentX = 16748
_ExtentY = 12197
_Version = 393216
Tabs = 1
TabHeight = 520
TabCaption(0) = "建议维护"
TabPicture(0) = "frmJBJYWH.frx":0000
Tab(0).ControlEnabled= -1 'True
Tab(0).Control(0)= "Label1"
Tab(0).Control(0).Enabled= 0 'False
Tab(0).Control(1)= "Label2"
Tab(0).Control(1).Enabled= 0 'False
Tab(0).Control(2)= "btn_save"
Tab(0).Control(2).Enabled= 0 'False
Tab(0).Control(3)= "btn_del"
Tab(0).Control(3).Enabled= 0 'False
Tab(0).Control(4)= "btn_edit"
Tab(0).Control(4).Enabled= 0 'False
Tab(0).Control(5)= "btn_add"
Tab(0).Control(5).Enabled= 0 'False
Tab(0).Control(6)= "lvwXMu"
Tab(0).Control(6).Enabled= 0 'False
Tab(0).Control(7)= "tvwXMu"
Tab(0).Control(7).Enabled= 0 'False
Tab(0).Control(8)= "txtJYNR"
Tab(0).Control(8).Enabled= 0 'False
Tab(0).Control(9)= "txtmc"
Tab(0).Control(9).Enabled= 0 'False
Tab(0).ControlCount= 10
Begin VB.TextBox txtmc
Height = 345
Left = 3780
TabIndex = 10
Top = 4230
Width = 5475
End
Begin VB.TextBox txtJYNR
Height = 1065
Left = 3780
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 8
Top = 4620
Width = 5475
End
Begin MSComctlLib.TreeView tvwXMu
Height = 5985
Left = 120
TabIndex = 1
Top = 480
Width = 2775
_ExtentX = 4895
_ExtentY = 10557
_Version = 393217
Style = 7
Appearance = 1
End
Begin MSComctlLib.ListView lvwXMu
Height = 3585
Left = 2910
TabIndex = 2
Top = 480
Width = 6465
_ExtentX = 11404
_ExtentY = 6324
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = 0 'False
FullRowSelect = -1 'True
GridLines = -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 = 2
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "建议名称"
Object.Width = 3528
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "建议内容"
Object.Width = 10583
EndProperty
End
Begin XPControls.XPCommandButton btn_add
Height = 465
Left = 3570
TabIndex = 3
Top = 5970
Width = 1245
_ExtentX = 2196
_ExtentY = 820
Caption = "新增"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin XPControls.XPCommandButton btn_edit
Height = 495
Left = 4920
TabIndex = 4
Top = 5940
Width = 1305
_ExtentX = 2302
_ExtentY = 873
Caption = "修改"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin XPControls.XPCommandButton btn_del
Height = 495
Left = 6450
TabIndex = 5
Top = 5940
Width = 1275
_ExtentX = 2249
_ExtentY = 873
Caption = "删除"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin XPControls.XPCommandButton btn_save
Height = 465
Left = 7890
TabIndex = 6
Top = 5940
Width = 1305
_ExtentX = 2302
_ExtentY = 820
Caption = "保存"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.Label Label2
Caption = "建议内容"
Height = 225
Left = 3000
TabIndex = 9
Top = 5070
Width = 885
End
Begin VB.Label Label1
Caption = "建议名称"
Height = 225
Left = 3000
TabIndex = 7
Top = 4290
Width = 795
End
End
End
Attribute VB_Name = "frmJBJYWH"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mblnChange As Boolean
Dim menuOperation As OperationType
Dim m_strMenu As String
Public Sub ShowForm(ByVal strMenu As String)
m_strMenu = strMenu
Me.Show vbModal
End Sub
'在树型结构中加载所有科室和项目
Public Function LoadKeShiAndXiangMu(ByRef tvwXMu As TreeView) As Boolean
On Error GoTo ErrMsg
Dim strSQL As String
Dim rsKS As ADODB.Recordset
Dim rsXX As ADODB.Recordset
Dim nodTemp As Node
Screen.MousePointer = vbHourglass
'获取所有科室
strSQL = "select KSID,KSMC from SET_KSSZ" _
& " order by SXH"
Set rsKS = New ADODB.Recordset
rsKS.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
If rsKS.EOF Then
MsgBox "当前尚未添加任何科室，无法进行其它操作！", vbInformation, "提示"
GoTo ExitLab
End If
'添加根节点
Set nodTemp = tvwXMu.Nodes.Add(, , HEADER, "所有科室")
nodTemp.Expanded = True
'循环添加所有科室
With tvwXMu
Do
'关键字长度：1＋2＝3
Set nodTemp = .Nodes.Add(HEADER, tvwChild, HEADER & rsKS("KSID"), rsKS("KSMC"))
'检索该科室下的所有体检项目
strSQL = "select JBID,JBMC from SET_QHJBZB" _
& " where KSID='" & rsKS("KSID") & "'"
Set rsXX = New ADODB.Recordset
rsXX.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
If Not rsXX.EOF Then
Do
'关键字长度：1＋7＝8
.Nodes.Add HEADER & rsKS("KSID"), tvwChild, HEADER & rsXX("JBID"), rsXX("JBMC")
rsXX.MoveNext
Loop While Not rsXX.EOF
rsXX.Close
End If
rsKS.MoveNext
Loop While Not rsKS.EOF
End With
rsKS.Close
Set tvwXMu.SelectedItem = tvwXMu.Nodes(1)
LoadKeShiAndXiangMu = True
GoTo ExitLab
ErrMsg:
MsgBoxW Err
ExitLab:
Screen.MousePointer = vbDefault
End Function
Private Sub btn_add_Click()
'权限验证
' If g_blnIsNew Then
' If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, INSERT_W) Then GoTo ExitLab
' End If
'验证完毕
ClearInput
btn_add.Enabled = False
btn_edit.Enabled = False
btn_save.Enabled = True
EnableInput True
txtmc.SetFocus
menuOperation = Add
ExitLab:
End Sub
'清除输入控件
Private Sub ClearInput()
txtmc.Text = ""
txtJYNR.Text = ""
End Sub
Private Sub btn_del_Click()
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim itmXMu As ListItem
Dim cmd As ADODB.Command
Dim intIndex As Integer
Me.MousePointer = vbHourglass
' '权限验证
' If g_blnIsNew Then
' If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, DELETE_W) Then GoTo ExitLab
' End If
' '验证完毕
If lvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
If MsgBox("确实要删除体检建议项“" & lvwXMu.SelectedItem.Text & "”吗？", _
vbQuestion + vbYesNo + vbDefaultButton2, "提示") = vbNo Then GoTo ExitLab
strSQL = "delete from SET_QHJBMXB" _
& " where JYID='" & Mid(lvwXMu.SelectedItem.Key, 2) & "'"
Set cmd = New ADODB.Command
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -