企业管理

开发平台：
Visual Basic

+：源码内容
							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

						