📄 frmxmsz.frm
字号:
Begin VB.Frame Frame2
Appearance = 0 'Flat
BackColor = &H00D3DABC&
ForeColor = &H80000008&
Height = 495
Left = 1200
TabIndex = 23
Top = 2790
Width = 3810
Begin VB.OptionButton optXXMale
BackColor = &H00D3DABC&
Caption = "男"
Height = 255
Left = 1440
TabIndex = 10
Top = 180
Width = 615
End
Begin VB.OptionButton optXXNNTY
BackColor = &H00D3DABC&
Caption = "所有"
Height = 255
Left = 150
TabIndex = 9
Top = 180
Value = -1 'True
Width = 855
End
Begin VB.OptionButton optXXFemale
BackColor = &H00D3DABC&
Caption = "女"
Height = 255
Left = 2640
TabIndex = 11
Top = 180
Width = 615
End
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "价格"
Height = 195
Left = 765
TabIndex = 41
Top = 2520
Width = 360
End
Begin VB.Label Label20
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "显示顺序"
Height = 195
Left = 2775
TabIndex = 36
Top = 2520
Width = 720
End
Begin VB.Label Label19
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "是否有建议项"
Height = 195
Left = 330
TabIndex = 35
Top = 4035
Width = 1080
End
Begin VB.Label Label10
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "是否进入小结"
Height = 195
Left = 330
TabIndex = 34
Top = 3540
Width = 1080
End
Begin VB.Label lblXMLX
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "项目类型"
Height = 195
Left = 405
TabIndex = 33
Top = 810
Width = 720
End
Begin VB.Label Label16
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "五笔简码"
Height = 195
Left = 3825
TabIndex = 32
Top = 2325
Visible = 0 'False
Width = 720
End
Begin VB.Label Label15
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "拼音简码"
Height = 195
Left = 405
TabIndex = 31
Top = 2085
Width = 720
End
Begin VB.Label Label14
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "说明"
Height = 195
Left = 750
TabIndex = 30
Top = 4485
Width = 360
End
Begin VB.Label Label13
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "名称"
Height = 195
Left = 2265
TabIndex = 29
Top = 300
Width = 360
End
Begin VB.Label Label12
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "项目ID"
Height = 195
Left = 570
TabIndex = 28
Top = 300
Width = 525
End
Begin VB.Label Label9
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "性别"
Height = 195
Left = 765
TabIndex = 27
Top = 3000
Width = 360
End
End
End
Attribute VB_Name = "frmXMSZ"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim menuOperation As OperationType
Dim m_strMenu As String
Public Sub ShowForm(ByVal strMenu As String)
m_strMenu = strMenu
Me.Show vbModal
End Sub
Private Sub cmbXXSXH_KeyPress(KeyAscii As Integer)
EnterToTab KeyAscii
End Sub
Private Sub cmdAdd_Click()
Dim strKey As String
Dim i As Integer
Dim strSQL As String
Dim rsSXH As ADODB.Recordset
Me.MousePointer = vbHourglass
'权限验证
If g_blnIsNew Then
If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, INSERT_W) Then GoTo ExitLab
End If
'验证完毕
If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
strKey = Mid(tvwXMu.SelectedItem.Key, 2)
'是否选择了根节点
If Len(strKey) = 0 Then GoTo ExitLab
menuOperation = Add
fraXX.Visible = True
cmdAdd.Enabled = False
cmdDelete.Enabled = False
cmdModify.Enabled = False
cmdSave.Enabled = True
'取出当前科室
strKey = Left(strKey, 2)
txtXXID.Text = GetXXID(strKey)
txtXXMC.Text = ""
txtXXMC.Tag = "" '清除Tag标志
txtXXPYSX.Text = ""
txtXXPYSX.Tag = "" '清除Tag标志
txtXXWBSX.Text = ""
txtXXPrice.Text = ""
txtXXSM.Text = ""
txtExpression.Text = ""
txtExpression.Tag = ""
chkHavePhoto.Value = vbUnchecked
chkHavePhoto.Tag = ""
EnableXXInput True
txtXXMC.SetFocus
strSQL = "select SXH from SET_SXH" _
& " where SXH not in (" _
& "select SXH from SET_XX" _
& " where left(XXID,2)='" & strKey & "')"
'打开记录集
Set rsSXH = New ADODB.Recordset
rsSXH.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'清空可能存在的显示
cmbXXSXH.Clear
For i = 1 To rsSXH.RecordCount
cmbXXSXH.AddItem rsSXH("SXH")
rsSXH.MoveNext
Next
If rsSXH.RecordCount > 0 Then
cmbXXSXH.ListIndex = 0
rsSXH.Close
Else
MsgBox "添加的同级项目数已经达到最大，请删除掉一部分项目后再添加！", vbInformation, "提示"
cmdExit_Click
End If
Set rsSXH = Nothing
ExitLab:
Me.MousePointer = vbDefault
End Sub
Private Sub cmdDelete_Click()
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim rstemp As ADODB.Recordset
Dim strKey As String
Dim nodTemp As Node
Dim lngIndex As Long
Me.MousePointer = vbHourglass
'权限验证
If g_blnIsNew Then
If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, DELETE_W) Then GoTo ExitLab
End If
'验证完毕
'是否有选择
If tvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
strKey = Mid(tvwXMu.SelectedItem.Key, 2)
Select Case Len(strKey)
Case 0, 2 '选择了根节点，或者科室
GoTo ExitLab
Case 7 '选择了项目
'确认删除
If MsgBox("该操作不可恢复！" & vbCrLf & "确实要删除体检项目“" _
& tvwXMu.SelectedItem.Text & "”吗？", _
vbExclamation + vbYesNo + vbDefaultButton2, "警告") = vbNo Then
GoTo ExitLab
End If
'检查该项目是否已经存在于组合中
'如果存在，则禁止删除
strSQL = "select Count(*) from SET_ZH_Data" _
& " where XXID='" & strKey & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
If rstemp(0) > 0 Then
MsgBox "该体检项目存在于 " & rstemp.RecordCount & _
" 个项目组合中，为了维护数据库的完整性，无法删除！" & vbCrLf _
& "如果确实要删除该项目，您可以先从这些组合里面移除该项目，然后删除！", _
vbCritical, "警告"
GoTo ExitLab
End If
rstemp.Close
'确认删除字典数据
strSQL = "select Count(*) from DM_XX" _
& " where XXID='" & strKey & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
If rstemp(0) > 0 Then
If MsgBox("该体检项目已经存在 " & rstemp(0) _
& " 条字典数据。如果删除该项目，将同时删除这些字典数据！" _
& vbCrLf & "您确认要继续吗？", _
vbExclamation + vbYesNo + vbDefaultButton2, "警告") = vbNo Then
GoTo ExitLab
End If
End If
rstemp.Close
'确认模板数据
strSQL = "select Count(*) from DM_XM_Value" _
& " where XMID='" & strKey & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
If rstemp(0) > 0 Then
If MsgBox("该体检项目已经存在 " & rstemp(0) _
& " 条模板数据。如果删除该项目，将同时删除这些模板数据！" _
& vbCrLf & "您确认要继续吗？", _
vbExclamation + vbYesNo + vbDefaultButton2, "警告") = vbNo Then
GoTo ExitLab
End If
End If
rstemp.Close
'从数据库删除
strSQL = "delete from SET_XX" _
& " where XXID='" & strKey & "'"
GCon.Execute strSQL
'删除字典数据
strSQL = "delete from DM_XX" _
& " where XXID='" & strKey & "'"
GCon.Execute strSQL
'删除模板数据
strSQL = "delete from DM_XM_Value" _
& " where XMID='" & strKey & "'"
GCon.Execute strSQL
'从树形结构上删除
lngIndex = tvwXMu.SelectedItem.Index
tvwXMu.Nodes.Remove lngIndex
Set tvwXMu.SelectedItem = tvwXMu.Nodes(lngIndex - 1)
'调用单击事件
tvwXMu_NodeClick tvwXMu.SelectedItem
End Select
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -