📄 +
字号:
VERSION 5.00
Begin VB.Form RsItem_FrmPay
BorderStyle = 3 'Fixed Dialog
Caption = "人事项目选择"
ClientHeight = 3780
ClientLeft = 45
ClientTop = 330
ClientWidth = 5325
HelpContextID = 2212011
Icon = "基础设置_人事项目选择.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3780
ScaleWidth = 5325
ShowInTaskbar = 0 'False
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton Cmd_Cancel
Caption = "取消(&C)"
Height = 300
Left = 4095
TabIndex = 10
Top = 3390
Width = 1120
End
Begin VB.CommandButton Cmd_Ok
Caption = "保存(&S)"
Height = 300
Left = 2895
TabIndex = 9
Top = 3390
Width = 1120
End
Begin VB.Frame Frame1
Height = 3225
Left = 60
TabIndex = 0
Top = 60
Width = 5175
Begin VB.ListBox Lst_PicthON
Height = 1140
Index = 1
Left = 3870
TabIndex = 12
Top = 2040
Width = 1095
End
Begin VB.ListBox Lst_Pre
Height = 960
Index = 1
Left = 795
TabIndex = 11
Top = 1770
Width = 1125
End
Begin VB.CommandButton Cmd_L
Caption = "<"
Height = 315
Left = 2265
TabIndex = 8
Top = 2160
Width = 630
End
Begin VB.CommandButton Cmd_AllL
Caption = "<<"
Height = 315
Left = 2265
TabIndex = 7
Top = 1680
Width = 630
End
Begin VB.CommandButton Cmd_R
Caption = ">"
Height = 315
Left = 2265
TabIndex = 6
Top = 1170
Width = 630
End
Begin VB.CommandButton Cmd_AllR
Caption = ">>"
Height = 315
Left = 2265
TabIndex = 5
Top = 690
Width = 630
End
Begin VB.ListBox Lst_PicthON
Height = 2580
Index = 0
Left = 3000
TabIndex = 4
Top = 510
Width = 2040
End
Begin VB.ListBox Lst_Pre
Height = 2580
Index = 0
Left = 105
TabIndex = 2
Top = 510
Width = 2040
End
Begin VB.Label Lbl_PicthON
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "选中项:"
Height = 180
Left = 3120
TabIndex = 3
Top = 300
Width = 630
End
Begin VB.Label Lbl_Pre
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "备选项:"
Height = 180
Left = 180
TabIndex = 1
Top = 300
Width = 630
End
End
End
Attribute VB_Name = "RsItem_FrmPay"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*******************************************************
'* 模 块 名 称 :人事项目选择
'* 功 能 描 述 :将需要保存历史记录的、与计算工资有关的人事项目选入到
'* 工资表，用*号表示。选入到工资表中的人事项目，如果它在
'* 它在工资表中无数据，可取消选择。
'* 程序员姓名 :田建秀
'* 最后修改人 :田建秀
'* 最后修改时间:2002/1/21
'* 备 注:
'*******************************************************
Option Explicit
Dim Rsc As New ADODB.Recordset
Dim Sql As String
Dim I As Long
Dim Str_RightEdit As String '编辑(新增、修改、删除)权限索引
Private Sub Cmd_AllL_Click()
Dim FidName As String
I = 0
With Lst_PicthON(0)
Do While I <= .ListCount - 1
If Left(Trim(Lst_PicthON(0).List(I)), 1) <> "*" Then
'还没有成为PM_payroll表的字段
Call Lr(I)
Else
With Lst_PicthON(1)
FidName = Left(Trim(.List(I)), InStr(Trim(.List(I)), " ") - 1)
If LCase(Trim(FidName)) = "empno" Or LCase(Trim(FidName)) = "empname" _
Or LCase(Trim(FidName)) = "deptcode" Or LCase(Trim(FidName)) = "empsort" Then
I = I + 1
Else
If Rsc.State = 1 Then Rsc.Close
Sql = "select * from PM_Payroll where " & FidName & " is not null"
Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sql)
If Not Rsc.EOF Then
Call Xtxxts("“" & Right(Trim(Lst_PicthON(0).List(I)), Len(Trim(Lst_PicthON(0).List(I))) - 1) & "”在工资数据表中已有数据，不能返回为备选项!", 0, 1)
I = I + 1
Else
Call Lr(I)
End If
End If
End With
End If
Loop
End With
LCount
End Sub
Private Sub Cmd_AllR_Click()
With Lst_Pre(0)
For I = 0 To .ListCount - 1
Lst_PicthON(0).AddItem .List(I)
Lst_PicthON(1).AddItem Lst_Pre(1).List(I)
Next
.Clear
End With
LCount
End Sub
Private Sub Cmd_Cancel_Click()
Unload Me
End Sub
Private Sub Cmd_L_Click()
Dim FidName
If Lst_PicthON(0).listindex = -1 Then
Exit Sub
End If
If Left(Trim(Lst_PicthON(0).Text), 1) <> "*" Then
'还没有成为PM_payroll表的字段
Call Lr(Lst_PicthON(0).listindex)
Else
With Lst_PicthON(1)
FidName = Left(Trim(.List(Lst_PicthON(0).listindex)), InStr(Trim(.List(Lst_PicthON(0).listindex)), " ") - 1)
If LCase(Trim(FidName)) = "empno" Or LCase(Trim(FidName)) = "empname" _
Or LCase(Trim(FidName)) = "deptcode" Or LCase(Trim(FidName)) = "empsort" Then
Exit Sub
End If
If Rsc.State = 1 Then Rsc.Close
Sql = "select * from PM_Payroll where " & FidName & " is not null"
Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sql)
If Not Rsc.EOF Then
Call Xtxxts("“" & Right(Trim(Lst_PicthON(0).Text), Len(Trim(Lst_PicthON(0).Text)) - 1) & "”在工资数据表中已有数据，不能返回为备选项!", 0, 1)
Else
Call Lr(Lst_PicthON(0).listindex)
End If
End With
End If
LCount
End Sub
Private Sub Lr(listindex As Long)
'将选中项返回成为备选项
With Lst_PicthON(0)
Lst_Pre(0).AddItem .List(listindex)
Lst_Pre(1).AddItem Lst_PicthON(1).List(listindex)
Lst_PicthON(1).RemoveItem (listindex)
.RemoveItem (listindex)
End With
End Sub
Private Sub Cmd_Ok_Click()
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
Exit Sub
End If
Dim Sql1 As String
Dim FidName As String
Sql = ""
Sql1 = " "
With Lst_PicthON(1)
For I = 0 To .ListCount - 1
If Left(Trim(Lst_PicthON(0).List(I)), 1) <> "*" Then
Sql = Sql & " alter table pm_Payroll add " & .List(I)
Sql1 = Sql1 & " update Rs_Items set AddMinusItem=1 where " & _
" FieldName='" & _
Left(Trim(.List(I)), InStr(Trim(.List(I)), " ") - 1) & _
"'"
End If
Next
End With
With Lst_Pre(1)
For I = 0 To .ListCount - 1
If Left(Trim(Lst_Pre(0).List(I)), 1) = "*" Then
FidName = Left(Trim(.List(I)), InStr(Trim(.List(I)), " ") - 1)
Sql = Sql & " alter table pm_Payroll drop column " & FidName
Sql1 = Sql1 & " update Rs_Items set AddMinusItem=0 where " & _
" FieldName='" & FidName & "'"
End If
Next
End With
On Error GoTo Err1
If Trim(Sql) = "" Then
Unload Me
Exit Sub
End If
With Cw_DataEnvi.DataConnect
.BeginTrans
.Execute Sql
.Execute Sql1
.CommitTrans
End With
Call Xtxxts("转移成功!", 0, 4)
Unload Me
Exit Sub
Err1:
Cw_DataEnvi.DataConnect.RollbackTrans
Call Xtxxts("转移不成功!", 0, 1)
End Sub
Private Sub Cmd_R_Click()
With Lst_Pre(0)
If .listindex = -1 Then
Exit Sub
End If
Lst_PicthON(0).AddItem .List(.listindex)
Lst_PicthON(1).AddItem Lst_Pre(1).List(.listindex)
Lst_Pre(1).RemoveItem (.listindex)
.RemoveItem (.listindex)
End With
LCount
End Sub
Private Sub Form_Load()
Lst_Pre(1).Visible = False
Lst_PicthON(1).Visible = False
Sql = "select o.Name as TableName,ChName,fieldname ,t.name as typeName,c.length,c.scale from " & _
" syscolumns c inner join sysobjects o on c.id=o.id " & _
" inner join systypes t on c.xtype=t.xusertype " & _
" inner join rs_items r on r.fieldname=c.name " & _
" where (o.name='Rs_basicInfo' or o.name='rs_extendInfo') " & _
" and r.addminusitem=0 and (sid=1 or sid=2) order by o.name,itemid "
Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sql)
Do While Not Rsc.EOF
Lst_Pre(0).AddItem Trim(Rsc!ChName)
Call Add1(Rsc, Lst_Pre(1))
Rsc.MoveNext
Loop
If Rsc.State = 1 Then Rsc.Close
Sql = "select o.Name as TableName,ChName,fieldname ,t.name as typeName,c.length,c.scale from " & _
" syscolumns c inner join sysobjects o on c.id=o.id " & _
" inner join systypes t on c.xtype=t.xusertype " & _
" inner join rs_items r on r.fieldname=c.name " & _
" where (o.name='Rs_basicInfo' or o.name='rs_extendInfo') " & _
" and r.addminusitem=1 and (sid=1 or sid=2) order by o.name,itemid "
Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sql)
Do While Not Rsc.EOF
Lst_PicthON(0).AddItem "*" & Space(1) & Trim(Rsc!ChName)
Call Add1(Rsc, Lst_PicthON(1))
Rsc.MoveNext
Loop
LCount
'编辑(新增、修改、删除)权限索引
Str_RightEdit = "Pm_RsItem_edit"
Exit Sub
End Sub
Private Sub LCount()
Lbl_Pre.Caption = "备选项:" & Space(2) & "共" & Lst_Pre(0).ListCount & "项"
Lbl_PicthON.Caption = "选中项:" & Space(2) & "共" & Lst_PicthON(0).ListCount & "项"
End Sub
Private Sub Add1(Rsc As ADODB.Recordset, lst As ListBox)
With Rsc
If Left(Trim(!TypeName), 1) = "n" Then
'unicode数据类型
lst.AddItem Trim(!FieldName) & _
Space(1) & Trim(!TypeName) & _
"(" & !Length / 2 & ") null"
ElseIf LCase(Trim(!TableName)) = "rs_extendinfo" Then
lst.AddItem Trim(!FieldName) & _
Space(1) & Trim(!TypeName) & _
"(" & !Length & ") null"
ElseIf !Scale <> 0 And LCase(Trim(!TypeName)) <> "datetime" Then
lst.AddItem Trim(!FieldName) & _
Space(1) & Trim(!TypeName) & _
"(" & !Length & "," & !Scale & ") null"
ElseIf LCase(Trim(!TypeName)) = "bit" Or LCase(Trim(!TypeName)) = "datetime" Or LCase(Trim(!TypeName)) = "image" Then
lst.AddItem Trim(!FieldName) & _
Space(1) & Trim(!TypeName)
Else
lst.AddItem Trim(!FieldName) & _
Space(1) & Trim(!TypeName) & _
"(" & !Length & ") null"
End If
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set Rsc = Nothing
End Sub
Private Sub Lst_PicthON_dblClick(Index As Integer)
Call Cmd_L_Click
End Sub
Private Sub Lst_Pre_DblClick(Index As Integer)
Call Cmd_R_Click
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -