📄
字号:
Private Sub Form_KeyPress(KeyAscii As Integer) '控 制 焦 点 转 移
jdzygs = 10
Select Case KeyAscii
Case vbKeyReturn
If Kjjdzy(jdzygs) Then
KeyAscii = 0
End If
Case 39 '屏蔽"'"
KeyAscii = 0
End Select
End Sub
Private Sub Form_Load()
SizeControls imgSplitter.Left
'填充考核类别列表框
Call AddTitleCode
str_titleRoot = TitleRoot()
int_EmpID = -1
Add_Tree
'打印报表标题信息
ReportTitle = "单人考核数据录入"
'调入打印页面设置窗体
XtReportCode = "Khgl_CheckData"
Load Dyymctbl
'以下为文本框处理程序(读入文本框录入信息)
TextGroupCode = "Khgl_CheckData"
Call Drwbkxx(TextGroupCode, Textvar(), Textboolean(), Textint(), Textstr())
Call Wbkcsh
'调入网格设置信息
GridCode = "Khgl_CheckData"
Call BzWgcsh(CzxsGrid, GridCode, GridInf(), GridBoolean(), GridInt(), GridStr())
Qslz = GridInf(1)
Sjhgd = GridInf(2)
Szzls = CzxsGrid.Cols - 1
'填 充 网 格
Call Cxnrtcwg
'初始化toolbar,tab卡状态
StTab.Tab = 0
StTab.TabEnabled(1) = False
'显示当前考核类别名称
Imgcbo_Title.Refresh
'Frame1.Enabled = False
'设置为非录入状态
Lrzt = 0
End Sub
Private Sub Cxnrtcwg() '查询内容填充网格
Dim Sqlstr As String '查询连接串
Dim Jsqte As Long '查询临时使用变量
'为加快显示速度,将网格刷新动作冻结
CzxsGrid.Redraw = False
'[>>查询连接串
Sqlstr = " SELECT BaseMainID,ValListName,ValListCode,ValListCodeID, EmpID, EmpNo,EmpName, DeptName,DeptCode " & _
" FROM Kh_v_BaseMain where empid=" & int_EmpID & _
" and TitleCode='" & str_TitleCode & "'" & _
" and GroupCode IS NULL" & _
" order by ValListCode,ValListCodeID "
'<<]
Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
With Cxnrrec
CzxsGrid.Rows = CzxsGrid.FixedRows
If .EOF And .BOF Then
CzxsGrid.Redraw = True
Exit Sub
End If
Jsqte = CzxsGrid.FixedRows
Do While Not .EOF
CzxsGrid.AddItem ""
Call Jltcwg(Cxnrrec, Jsqte) '调入填充网格子过程
CzxsGrid.RowHeight(Jsqte) = Sjhgd '设置网格高度
.MoveNext
Jsqte = Jsqte + 1
Loop
End With
'将网格刷新动作解冻
CzxsGrid.Redraw = True
'判断考核数据有效性
Call IsSuccess
End Sub
Private Sub Jltcwg(Jlbrec As ADODB.Recordset, Rowjsq As Long) '记录内容填充网格
'[>>以下为自定义部分
With Jlbrec
CzxsGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls)) = Trim(.Fields("BaseMainID") & "") '考核数据主表ID号
CzxsGrid.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls)) = Trim(.Fields("EmpNo") & "") '职工工号
CzxsGrid.TextMatrix(Rowjsq, Sydz("003", GridStr(), Szzls)) = Trim(.Fields("EmpName") & "") '姓名
CzxsGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls)) = Trim(.Fields("ValListCode") & "") '测评者编码
CzxsGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls)) = Trim(.Fields("ValListName") & "") '测评者
CzxsGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls)) = Trim(.Fields("ValListCodeID") & "") '测评者序号
End With
'以上为自定义部分<<]
End Sub
Private Sub Form_Resize()
On Error Resume Next
Dim St_tab As Integer
If Me.Height < 7000 Then Me.Height = 7000
If Me.Width < 10000 Then Me.Width = 10000
StTab.Width = Me.Width - (TreeView.Width + 300)
StTab.Height = Me.Height - (StTab.Top + 400)
TreeView.Height = Me.Height - (TreeView.Top + 400)
imgSplitter.Height = TreeView.Height
St_tab = StTab.Tab
StTab.Tab = 0
CzxsGrid.Width = StTab.Width - CzxsGrid.Left * 2
CzxsGrid.Height = StTab.Height - 600
StTab.Tab = St_tab
GsToolbar.Left = Me.Width - GsToolbar.Width - 140
End Sub
Private Sub Form_Unload(Cancel As Integer) '窗体卸载
Set Cxnrrec = Nothing
Set Rec_CodeSet = Nothing
Unload Dyymctbl
End Sub
Private Function Bclrsj() As Boolean '判断录入数据有效性,并保存数据
Dim Jsqte As Integer
'对文本框录入内容进行为零和为空判断(固定不变)
With Rec_CodeSet
For Jsqte = 0 To Max_Text_Index
If Textint(Jsqte, 8) = 1 Then '字段不能为空
If Len(Trim(LrText(Jsqte).Text)) = 0 Then
Tsxx = Textstr(Jsqte, 7) & "不能为空!"
Call Xtxxts(Tsxx, 0, 1)
LrText(Jsqte).SetFocus
Bclrsj = False
Exit Function
End If
Else
If Textint(Jsqte, 8) = 2 Then '字段不能为零
If Val(Trim(LrText(Jsqte).Text)) = 0 Then
Tsxx = Textstr(Jsqte, 7) & "不能为零!"
Call Xtxxts(Tsxx, 0, 1)
LrText(Jsqte).SetFocus
Bclrsj = False
Exit Function
End If
End If
End If
Next Jsqte
'对需要进行事后判断的文本框录入内容进行有效性判断 (固定不变)
For Jsqte = 0 To Max_Text_Index
If Textint(Jsqte, 9) = 0 Or Textint(Jsqte, 9) = 2 Then
If Not TextYxxpd(Jsqte) Then
Exit Function
End If
End If
Next Jsqte
If Lrzt = 1 Then '增 加
'[>>判断编码是否重复
If .State = 1 Then .Close
.Open "SELECT * FROM Kh_BaseMain ", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
' If Not .EOF Then
' Tsxx = "类别编码重复!"
' Call Xtxxts(Tsxx, 0, 1)
' LrText(0).SetFocus
'
' Bclrsj = False
' Exit Function
' End If
'判断记录内容无误后,将记录内容写入数据表
On Error GoTo Swcwcl
Cw_DataEnvi.DataConnect.BeginTrans
.AddNew
.Fields("BaseMainID") = MaxNum(0) 'ID号
.Fields("TitleCode") = str_TitleCode '考核类别
.Fields("EmpID") = int_EmpID '对象编码
.Fields("ValListCode") = Trim(LrText(3).Tag) '测评者
.Fields("ValListCodeID") = MaxNum(1) '测评者序号
.Fields("BaseTotal") = 0 '考核总分
.Update
Cw_DataEnvi.DataConnect.CommitTrans
'将记录加入网格
Call Cxnrtcwg
Tsxx = "保存完毕!"
Call Xtxxts(Tsxx, 0, 4)
Call Cshlrxx(1)
LrText(3).SetFocus
'将网格按编码排序
' With CzxsGrid
' .Col = Sydz("001", GridStr(), Szzls)
' CzxsGrid.Sort = flexSortStringAscending
' End With
'<<]
End If
'保存记录成功,函数返回真值
Bclrsj = True
Exit Function
End With
Swcwcl:
Cw_DataEnvi.DataConnect.RollbackTrans
Tsxx = "存盘过程中出现错误,程序自动恢复保存前状态!"
Call Xtxxts(Tsxx, 0, 1)
Exit Function
End Function
Private Function Cshlrxx(lrztxx As Integer) As Boolean '初始化录入字段信息
TextChangeLock = True '关闭文本框Chang事件
If lrztxx = 1 Then
'增加新记录时将文本框清空
For Jsqte = 0 To Max_Text_Index
If Len(Trim(Textstr(Jsqte, 1))) <> 0 Then
LrText(Jsqte).Text = ""
LrText(Jsqte).Tag = ""
End If
TextValiJudgeLock(Jsqte) = True
Next Jsqte
'[>>
'在此处可添加新增记录时初始化设置
With RecTemp
Sqlstr = "SELECT EmpNo,EmpName,DeptName FROM Kh_v_Object Where TitleCode='" & str_TitleCode & "' and EmpID=" & int_EmpID
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
'记录如存在则读入其内容,否则提示记录已被其他人删除
If Not RecTemp.EOF Then
LrText(0).Text = Trim(.Fields("EmpNo") & "") '工号
LrText(1).Text = Trim(.Fields("EmpName") & "") '姓名
LrText(2).Text = Trim(.Fields("DeptName") & "") '部门
End If
End With
LrText(0).Enabled = False
LrText(1).Enabled = False
LrText(2).Enabled = False
'<<]
End If
Cshlrxx = True
TextChangeLock = False
End Function
Private Sub Scdqjl() '删 除 当 前 记 录
Dim yhAnswer As Integer
Dim aDo_Rec As New Recordset
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log("Khgl_CheckData_edit", Xtczybm, 1) Then
Exit Sub
End If
'非数据行不能删除
If CzxsGrid.Row < CzxsGrid.FixedRows Then
Exit Sub
End If
'用户确认是否删除记录
Tsxx = "请确认是否删除当前记录?"
yhAnswer = Xtxxts(Tsxx, 2, 2)
If yhAnswer = 2 Then
Exit Sub
End If
On Error GoTo Cwcl
Cw_DataEnvi.DataConnect.BeginTrans
'[>>以下需自定义部分
Cw_DataEnvi.DataConnect.Execute "delete Kh_BaseSub where BaseMainID = " & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls)))
Cw_DataEnvi.DataConnect.Execute "delete Kh_BaseMain where BaseMainID = " & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls)))
'Add_Tree
'以上为自定义部分<<]
Cw_DataEnvi.DataConnect.CommitTrans
'将记录加入网格
Call Cxnrtcwg
Exit Sub
Cwcl:
Cw_DataEnvi.DataConnect.RollbackTrans
If Err.Number = -2147217873 Then '(-2147217873 为SQL Server 2000通过建立外键产生的错误号)
Tsxx = "该测评者已经被使用,不能删除!"
Call Xtxxts(Tsxx, 0, 1)
Exit Sub
Else
Tsxx = "出现未知情况,该测评者不能被删除!"
Call Xtxxts(Tsxx, 0, 1)
Exit Sub
End If
End Sub
'*******************以下区域为编写自定义过程区域**********************
Private Sub Imgcbo_Title_Click()
int_EmpID = -1
str_TitleCode = GetComboKey(Imgcbo_Title, 0)
str_titleRoot = Mid(str_TitleCode, 1, int_titleRootlen)
str_TitleName = Imgcbo_Title.Text
Add_Tree
Call Cxnrtcwg
End Sub
Private Function AddTitleCode()
Dim RecExist As New Recordset
FillImageCombo Imgcbo_Title, "Khgl_TitleCompute", 1
Sqlstr = "SELECT TitleCode,titleName From Kh_Title where (endflag=1 and CloseFlag=0 and CreateTime=(select max(createTime) from kh_title where endflag=1 and CloseFlag=0))"
Set RecExist = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
If Not RecExist.EOF Then
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -