📄 frmjywh.frm
字号:
Left = 210
TabIndex = 14
Top = 1560
Width = 720
End
End
Begin VB.Frame Frame2
BackColor = &H00D3DABC&
Caption = "操作"
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1185
Left = 3390
TabIndex = 0
Top = 6030
Width = 6375
Begin XPControls.XPCommandButton cmdAdd
Height = 375
Left = 960
TabIndex = 1
Top = 240
Width = 1005
_ExtentX = 1773
_ExtentY = 661
Caption = "添加(&A)"
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 cmdModify
Height = 375
Left = 2700
TabIndex = 2
Top = 240
Width = 1005
_ExtentX = 1773
_ExtentY = 661
Caption = "修改(&M)"
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 cmdSave
Height = 375
Left = 4470
TabIndex = 3
Top = 240
Width = 1005
_ExtentX = 1773
_ExtentY = 661
Caption = "保存(&S)"
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 cmdDelete
Height = 375
Left = 960
TabIndex = 4
Top = 690
Width = 1005
_ExtentX = 1773
_ExtentY = 661
Caption = "删除(&D)"
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
Cancel = -1 'True
Height = 375
Left = 4470
TabIndex = 5
Top = 690
Width = 1005
_ExtentX = 1773
_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
Begin XPControls.XPCommandButton cmdExort
Height = 375
Left = 2700
TabIndex = 6
Top = 690
Width = 1005
_ExtentX = 1773
_ExtentY = 661
Caption = "导出(&E)"
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
End
Attribute VB_Name = "FrmJYWH"
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
Private Sub cmdAdd_Click()
ClearInput
cmdAdd.Enabled = False
cmdModify.Enabled = False
cmdSave.Enabled = True
EnableInput True
menuOperation = Add
End Sub
Private Sub cmdDelete_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 lvwXMu.SelectedItem Is Nothing Then GoTo ExitLab
If MsgBox("确实要删除体检建议项“" & lvwXMu.SelectedItem.Text & "”吗？", _
vbQuestion + vbYesNo + vbDefaultButton2, "提示") = vbNo Then GoTo ExitLab
strSQL = "delete from DM_ZJJY" _
& " where JYDMID='" & Mid(lvwXMu.SelectedItem.Key, 2) & "'"
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = GCon
cmd.CommandText = strSQL
cmd.Execute
intIndex = lvwXMu.SelectedItem.Index
lvwXMu.ListItems.Remove intIndex
If lvwXMu.ListItems.Count > 0 Then
If intIndex > 1 Then
Set lvwXMu.SelectedItem = lvwXMu.ListItems(intIndex - 1)
Else
Set lvwXMu.SelectedItem = lvwXMu.ListItems(intIndex)
End If
Else
txtZDJL.Text = ""
txtJYMC.Text = ""
txtJYNR.Text = ""
End If
lvwXMu_Click
GoTo ExitLab
ErrMsg:
Status = SetError(Err.Number, Err.Description, Err.Source)
ErrMsg Status
ExitLab:
Me.MousePointer = vbDefault
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdExort_Click()
Call ExportSuggestion(Me.CommonDialog1)
End Sub
Private Sub cmdModify_Click()
'是否有选择
If lvwXMu.SelectedItem Is Nothing Then Exit Sub
txtZDJL.Text = lvwXMu.SelectedItem.Text
txtJYMC.Text = lvwXMu.SelectedItem.SubItems(1)
txtJYNR.Text = lvwXMu.SelectedItem.SubItems(2)
If lvwXMu.SelectedItem.SubItems(3) = 0 Then
ChkSFJB.Value = vbUnchecked
ElseIf lvwXMu.SelectedItem.SubItems(3) = 1 Then
ChkSFJB.Value = vbChecked
End If
If lvwXMu.SelectedItem.SubItems(4) = 0 Then
ChkSFCJB.Value = vbUnchecked
ElseIf lvwXMu.SelectedItem.SubItems(4) = 1 Then
ChkSFCJB.Value = vbChecked
End If
cmdAdd.Enabled = False
cmdModify.Enabled = False
cmdSave.Enabled = True
cmdDelete.Enabled = False
EnableInput True
menuOperation = Modify
mblnChange = False
End Sub
Private Sub cmdSave_Click()
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim rstemp As ADODB.Recordset
Dim cmd As ADODB.Command
Dim strXMID As String '记录当前科室的ID号
Dim itmXMu As ListItem
Dim intOperation As OperationType
Me.MousePointer = vbHourglass
'是否输入了诊断结论
If txtZDJL.Text = "" Then
MsgBox "请输入诊断结论！", vbInformation, "提示"
txtZDJL.SetFocus
GoTo ExitLab
End If
'是否输入了建议名称
If txtJYMC.Text = "" Then
MsgBox "请输入建议名称！", vbInformation, "提示"
txtJYMC.SetFocus
GoTo ExitLab
End If
'是否输入了建议
If txtJYNR.Text = "" Then
MsgBox "请输入建议内容！", vbInformation, "提示"
txtJYNR.SetFocus
GoTo ExitLab
End If
'同一个科室内不允许重复
'诊断结论是否已经存在
strSQL = ""
If menuOperation = Add Then '添加
strSQL = "select count(*) from DM_ZJJY" _
& " where DMValue='" & txtZDJL.Text & "'"
Else '修改
If txtZDJL.Text <> lvwXMu.SelectedItem.Text Then
strSQL = "select count(*) from DM_ZJJY" _
& " where DMValue='" & txtZDJL.Text & "'"
End If
End If
If strSQL <> "" Then
strSQL = strSQL & " and KSID='" & Mid(tvwXMu.SelectedItem.Key, 2) & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenKeyset, adLockReadOnly
If rstemp(0) >= 1 Then
MsgBox "您输入的诊断结论已经存在！请核对后重新输入！", vbInformation, "提示"
txtZDJL.SetFocus
GoTo ExitLab
End If
rstemp.Close
End If
'建议名称是否已经存在
strSQL = ""
If menuOperation = Add Then '添加
strSQL = "select count(*) from DM_ZJJY" _
& " where JYMC='" & txtJYMC.Text & "'"
Else '修改
If txtZDJL.Text <> lvwXMu.SelectedItem.Text Then
strSQL = "select count(*) from DM_ZJJY" _
& " where JYMC='" & txtJYMC.Text & "'"
End If
End If
If strSQL <> "" Then
strSQL = strSQL & " and KSID='" & Mid(tvwXMu.SelectedItem.Key, 2) & "'"
Set rstemp = New ADODB.Recordset
rstemp.Open strSQL, GCon, adOpenKeyset, adLockReadOnly
If rstemp(0) >= 1 Then
MsgBox "您输入的建议名称已经存在！请核对后重新输入！", vbInformation, "提示"
txtJYMC.SetFocus
GoTo ExitLab
End If
rstemp.Close
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -