📄 frmprecontract.frm
字号:
ElseIf IsNull(rsTemp("SJYYXLH")) Then
strHealthID = strHealthID & "0001"
txtTJXH.Text = 1
rsTemp.Close
Else
strHealthID = strHealthID & LongToString(rsTemp("SJYYXLH") + 1, 4)
txtTJXH.Text = rsTemp("SJYYXLH") + 1
rsTemp.Close
End If
Set rsTemp = Nothing
txtGYYID.Text = strHealthID
fraTJBZ.Enabled = True
fraGRen.Enabled = True
Else '团体
'获取当前的最大编号
'获取当前最大的序列号
strYYID = Format(Date, "yyyymmdd")
strSQL = "select TJYYXLH from YY_XLH where RiQi='" & Date & "'"
Set rsTemp = New ADODB.Recordset
rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rsTemp.RecordCount = 0 Then
strYYID = strYYID & "001"
ElseIf IsNull(rsTemp("TJYYXLH")) Then
strYYID = strYYID & "001"
rsTemp.Close
Else
strYYID = strYYID & LongToString(rsTemp("TJYYXLH") + 1, 3)
rsTemp.Close
End If
Set rsTemp = Nothing
txtTYYID.Text = strYYID
fraTTi.Enabled = True
End If
'*******************************20040327 封闭完***************************************
menuOperation = Add
cmdAdd.Enabled = False
cmdModify.Enabled = False
cmdOK.Enabled = True
cmdDelete.Enabled = False
Exit Sub
ErrMsg:
Status = SetError(Err.Number, Err.Description, Err.Source)
ErrMsg Status
End Sub
Private Sub cmdCancel_Click()
Me.Hide
Unload Me
End Sub
Private Sub cmdDelete_Click()
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim strID As String 'id
Dim rsTemp As ADODB.Recordset
Dim i As Integer
Me.MousePointer = 11
'是否有选择
If Me.MSHFlexGrid1.TextMatrix(1, 1) = "" Then GoTo ExitLab
If MsgBox("该操作不可恢复！您确认要删除预约客户“" _
& Me.MSHFlexGrid1.TextMatrix(Me.MSHFlexGrid1.Row, 1) & "”吗？", _
vbQuestion + vbYesNo + vbDefaultButton2, "小心") = vbNo Then GoTo ExitLab
strID = Me.MSHFlexGrid1.TextMatrix(Me.MSHFlexGrid1.Row, 1)
If Len(strID) = 12 Then
strSQL = "delete from SET_GRXX" _
& " where GUID=" & Val(Me.MSHFlexGrid1.TextMatrix(Me.MSHFlexGrid1.Row, 0))
GCon.Execute strSQL
strSQL = "delete from YY_SJDJ" _
& " where GUID=" & Val(Me.MSHFlexGrid1.TextMatrix(Me.MSHFlexGrid1.Row, 0))
GCon.Execute strSQL
ElseIf Len(strID) = 11 Then
strSQL = "delete from YY_TJDJ" _
& " where YYID='" & strID & "'"
GCon.Execute strSQL
strSQL = "delete from FZ_FZSY where YYID='" & strID & "'"
GCon.Execute strSQL
strSQL = "delete from FZ_FZSJ where YYID='" & strID & "'"
GCon.Execute strSQL
strSQL = "delete from YY_TJDJDX where YYID='" & strID & "'"
GCon.Execute strSQL
strSQL = "delete from YY_TJDJTC where YYID='" & strID & "'"
GCon.Execute strSQL
End If
'移除在网格上的显示
'初始化网格
With Me.MSHFlexGrid1
.Clear
.Rows = 2
.Cols = 5
'流水号
.TextMatrix(0, 0) = "流水号"
.ColWidth(0) = 0
.TextMatrix(0, 1) = "预约编号"
.ColWidth(1) = Me.TextWidth(.TextMatrix(0, 0)) + 600
.TextMatrix(0, 2) = "预约人"
.ColWidth(2) = Me.TextWidth(.TextMatrix(0, 1)) + 200
.TextMatrix(0, 3) = "所属团体"
.ColWidth(3) = Me.TextWidth(.TextMatrix(0, 2)) + 200
.TextMatrix(0, 4) = "预约日期"
.ColWidth(4) = Me.TextWidth(.TextMatrix(0, 3)) + 500
'显示尚未体检，但已经预约的个人或团体
'首先显示团体
strSQL = "select YYID,LXR,TJRQ" _
& " from YY_TJDJ,SET_DW" _
& " where YY_TJDJ.DWID=SET_DW.DWID" _
& " and SFTJ=0"
Set rsTemp = New ADODB.Recordset
rsTemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
If rsTemp.RecordCount > 0 Then
rsTemp.MoveFirst
Do
If .TextMatrix(1, 1) = "" Then
i = 1
Else
i = .Rows
.Rows = i + 1
End If
.TextMatrix(i, 1) = rsTemp("YYID")
.TextMatrix(i, 2) = rsTemp("LXR")
.TextMatrix(i, 3) = ""
.TextMatrix(i, 4) = rsTemp("TJRQ")
If rsTemp("TJRQ") < Date Then
.Row = i
.col = 4
.CellBackColor = vbRed
End If
rsTemp.MoveNext
Loop Until rsTemp.EOF
rsTemp.Close
End If
'显示个人
strSQL = "select SET_GRXX.GUID,SET_GRXX.HealthID,YYRXM,YY_SJDJ.TJRQ" _
& " from YY_SJDJ,SET_GRXX" _
& " where YY_SJDJ.GUID=SET_GRXX.GUID" _
& " and SFTJ=0"
Set rsTemp = New ADODB.Recordset
rsTemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
If rsTemp.RecordCount > 0 Then
rsTemp.MoveFirst
Do
If .TextMatrix(1, 1) = "" Then
i = 1
Else
i = .Rows
.Rows = i + 1
End If
.TextMatrix(i, 0) = rsTemp("GUID")
.TextMatrix(i, 1) = rsTemp("HealthID")
.TextMatrix(i, 2) = rsTemp("YYRXM")
.TextMatrix(i, 3) = "个人"
.TextMatrix(i, 4) = rsTemp("TJRQ")
If DateValue(rsTemp("TJRQ")) < Date Then
.Row = i
.col = 4
.CellBackColor = vbRed
End If
rsTemp.MoveNext
Loop Until rsTemp.EOF
rsTemp.Close
End If
End With
MSHFlexGrid1_Click
GoTo ExitLab
ErrMsg:
Status = SetError(Err.Number, Err.Description, Err.Source)
ErrMsg Status
ExitLab:
Me.MousePointer = 0
End Sub
Private Sub cmdModify_Click()
If optGRen.Value = True Then '个人
If txtGYYID.Text <> "" Then
fraGRen.Enabled = True
cmdAdd.Enabled = False
cmdModify.Enabled = False
cmdOK.Enabled = True
cmdDelete.Enabled = False
fraTJBZ.Enabled = True
End If
Else '团体
If txtTYYID.Text <> "" Then
fraTTi.Enabled = True
cmdAdd.Enabled = False
cmdModify.Enabled = False
cmdOK.Enabled = True
cmdDelete.Enabled = False
End If
End If
End Sub
Private Sub cmdOK_Click()
On Error GoTo ErrMsg
Dim Status
Dim strSQL As String
Dim lngGUID As Long '
Dim strHealthID As String '个人id
Dim strYYID As String '团体预约id
Dim strMaxID As String '单位id
Dim rsTemp As ADODB.Recordset
Dim cmd As ADODB.Command
Dim i As Integer
Dim blnFirst As Boolean
Dim intSN As Integer
Me.MousePointer = 11
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = GCon
If optGRen.Value = True Then
'*************************************************
' 个人预约
'*************************************************
'是否有id号
If txtGYYID.Text = "" Then
MsgBox "请首先单击“添加”按钮，或者单击右侧欲修改的信息，以生成唯一的健康编号！", vbInformation, "提示"
txtGYYID.SetFocus
GoTo ExitLab
End If
'是否输入了姓名
If txtGYYRXM.Text = "" Then
MsgBox "请输入姓名！", vbInformation, "提示"
txtGYYRXM.SetFocus
GoTo ExitLab
End If
'如果输入了身份证号，则检查是否符合要求
txtGYYRSFZH.Text = Trim(txtGYYRSFZH.Text)
' If txtGYYRSFZH.Text <> "" Then
' If (Len(txtGYYRSFZH.Text) <> 15) And (Len(txtGYYRSFZH.Text) <> 18) Then
' MsgBox "身份证号只能是15位或者18位！请核对后重新输入！", vbInformation, "提示"
' txtGYYRSFZH.SetFocus
' goto ExitLab
' End If
' End If
If SFZHCheck(txtGYYRSFZH.Text) = False Then
MsgBox "身份证号只能是15位或者18位！请核对后重新输入！", vbInformation, "提示"
txtGYYRSFZH.SetFocus
GoTo ExitLab
End If
'体检日期是否已经过去
If dtpGTJRQ.Value < Date Then
MsgBox "您输入的体检日期无效！请核对后重新输入！", vbInformation, ""
dtpGTJRQ.SetFocus
GoTo ExitLab
End If
' '是否选择套餐
' If optGNo.Value = True Then
' '不选择套餐的时候检查是否选择了大项
' If chkGXMu.Value = 1 Then
' For i = 0 To lstGDXiang.ListCount - 1
' If lstGDXiang.Selected(i) = True Then
' blnFirst = True
' Exit For
' End If
' Next
'
' If blnFirst = False Then
' MsgBox "请选择体检大项！", vbInformation, "提示"
' lstGDXiang.SetFocus
' goto ExitLab
' End If
' End If
' Else
' '选择套餐时是否有选择
' If cmbGTCan.Text = "" Then
' MsgBox "请选择套餐！", vbInformation, "提示"
' cmbGTCan.SetFocus
' goto ExitLab
' End If
' End If
'▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
' 开始事务
'▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
GCon.BeginTrans
'▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲▲
On Error GoTo RollBack
'校验完毕，准备写入数据库
If menuOperation = Modify Then
lngGUID = Me.MSHFlexGrid1.TextMatrix(Me.MSHFlexGrid1.Row, 0)
strHealthID = txtGYYID.Text
Else
'获取当前的最大编号
'***************20040327 封闭************************
' strHealthID = Format(Date, "yyyymmdd")
' strSQL = "select SJYYXLH from YY_XLH where RiQi='" & Date & "'"
'***************20040327 封闭完**********************
'***************20040327 加入 闻************************
strHealthID = Format(dtpGTJRQ.Value, "yyyymmdd")
strSQL = "select SJYYXLH from YY_XLH where RiQi='" & dtpGTJRQ.Value & "'"
'***************20040327 加入完 闻**********************
Set rsTemp = New ADODB.Recordset
rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
If rsTemp.RecordCount = 0 Then
'往数据库里面插入一条记录
'***************20040327 封闭************************
' strSQL = "Insert into YY_XLH values(" & "'" & Date & "',null,1)"
'***************20040327 封闭完**********************
'***************20040327 加入 闻************************
strSQL = "Insert into YY_XLH values(" & "'" & dtpGTJRQ.Value & "',null,1)"
'***************20040327 加入完 闻**********************
strHealthID = strHealthID & "0001"
txtTJXH.Text = 1
ElseIf IsNull(rsTemp("SJYYXLH")) Then
'***************20040327 封闭************************
' strSQL = "Update YY_XLH" _
& " set SJYYXLH=1" _
& " where RiQi='" & Date & "'"
'***************20040327 封闭完**********************
'***************20040327 加入 闻************************
strSQL = "Update YY_XLH" _
& " set SJYYXLH=1" _
& " where RiQi='" & dtpGTJRQ.Value & "'"
'***************20040327 加入完 闻**********************
strHealthID = strHealthID & "0001"
txtTJXH.Text = 1
rsTemp.Close
Else
'***************20040327 封闭************************
' strSQL = "Update YY_XLH" _
& " set SJYYXLH=SJYYXLH+1" _
& " where RiQi='" & Date & "'"
'***************20040327 封闭完**********************
'***************20040327 加入 闻************************
strSQL = "Update YY_XLH" _
& " set SJYYXLH=SJYYXLH+1" _
& " where RiQi='" & dtpGTJRQ.Value & "'"
'***************20040327 加入完 闻**********************
strHealthID = strHealthID & LongToString(rsTemp("SJYYXLH") + 1, 4)
txtTJXH.Text = rsTemp("SJYYXL⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -