+

VB开发的ERP系统

        End Select
        
        '小数位数不能超过项目长度
        If Val(LrText(2)) > Val(LrText(1)) Then
            Call Xtxxts("小数位数不能超过项目长度!", 0, 1)
            Exit Function
        End If
        
       
        
        Call TableItem
        
        If Lrzt = 1 Then  '增 加
        
            '[>>
            '判断名称是否重复
            If .State = 1 Then .Close
            .Open "SELECT * FROM Rs_Items WHERE ChName= '" + Trim(LrText(0).Text) + "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
    
            If Not .EOF Then
                Tsxx = "项目名称重复!"
                Call Xtxxts(Tsxx, 0, 1)
                LrText(1).SetFocus
                Bclrsj = False
                Exit Function
            End If
        
        
            '判断记录内容无误后,将记录内容写入数据表
            On Error GoTo Swcwcl
            Cw_DataEnvi.DataConnect.BeginTrans
            If Rsc.State = 1 Then Rsc.Close
            Set Rsc = Cw_DataEnvi.DataConnect.Execute("select Itemid from Rs_Items  order by ItemId desc ")
            With Rsc
                If Not .EOF Then
                   ItemId = !ItemId + 1
                Else
                   ItemId = "1"
                End If
            End With
            
            '存储到Rs_Items表中
            .AddNew
            .Fields("ItemID") = ItemId                  '项目编码
            .Fields("Sid") = sID
            .Fields("FieldType") = 5
            .Fields("ChName") = Trim(LrText(0).Text)    '项目名称
            .Fields("FieldName") = ItemIde & ItemId
            .Fields("FieldLength") = Val(Trim(LrText(1).Text))    '项目长度
            If Trim(LrText(2).Text) = "" Then
                .Fields("FieldDotL") = 0
            Else
                .Fields("FieldDotL") = Val(Trim(LrText(2).Text))     '项目小数位
            End If
            .Fields("YnRoot") = 0
            .Fields("TableName") = TableName
            .Update
            '修改pm_Payroll的表结构
            Sql = "alter table " & TableName & " add  " & ItemIde & ItemId & " numeric(" & Val(LrText(1)) & "," & Val(LrText(2)) & ") " & _
                  " null constraint DF_" & ItemIde & ItemId & " default(0)"
            Cw_DataEnvi.DataConnect.Execute Sql
            Sql = " update " & TableName & " set " & ItemIde & ItemId & "=0"
            Cw_DataEnvi.DataConnect.Execute Sql
            Cw_DataEnvi.DataConnect.CommitTrans

            '将记录加入网格
            Sqlstr = "SELECT * FROM Rs_Items WHERE ItemId= " & ItemId
            Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
   
            With CzxsGrid
                .AddItem ""
                .RowHeight(.Rows - 1) = Sjhgd
                .Select .Rows - 1, Qslz
                Call Jltcwg(Cxnrrec, .Rows - 1)
            End With

            Tsxx = "保存完毕!"
            Call Xtxxts(Tsxx, 0, 4)
            
            Call Cshlrxx(1)
            LrText(0).SetFocus

            '将网格按编码排序
            With CzxsGrid
                .Col = 0
                CzxsGrid.Sort = flexSortNumericAscending
            End With
            Lbl_Count.Caption = "共" & CzxsGrid.Rows - CzxsGrid.FixedRows & "项"
            '<<]
    
        Else  '否则为修改记录
 
            On Error GoTo Swcwcl
            If .State = 1 Then .Close
            .Open "select * from rs_Items where ChName='" & Trim(LrText(0)) & "' and ItemID<>" & Val(CzxsGrid.TextMatrix(CzxsGrid.Row, 0)), Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
            If Not .EOF Then
                Call Xtxxts("项目名称重复!", 0, 1)
                Exit Function
            End If
            Cw_DataEnvi.DataConnect.BeginTrans
            ItemId = Val(CzxsGrid.TextMatrix(CzxsGrid.Row, 0))
            If .State = 1 Then .Close
            .Open "SELECT * FROM rs_Items WHERE ItemId= " & ItemId, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
     
            If Not .EOF Then
                .Fields("ChName") = Trim(LrText(0).Text)         '项目名称
                .Fields("FieldLength") = Val(Trim(LrText(1).Text))    '项目长度
                If Trim(LrText(2).Text) = "" Then
                    .Fields("FieldDotL") = 0
                Else
                    .Fields("FieldDotL") = Val(Trim(LrText(2).Text))     '项目小数位
                End If
                .Update
            End If
            Sql = "alter table " & TableName & " alter column " & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 1)) & " numeric(" & Val(LrText(1)) & "," & _
                  Val(LrText(2)) & ")"
            Cw_DataEnvi.DataConnect.Execute Sql
            Cw_DataEnvi.DataConnect.CommitTrans
   
            '刷新当前网格
            Sqlstr = "SELECT * FROM Rs_Items WHERE ItemID= " & ItemId
            Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
   
            With CzxsGrid
                Call Jltcwg(Cxnrrec, .Row)
            End With
   
        End If
     
        '保存记录成功,函数返回真值
        Bclrsj = True
        Exit Function
        
    End With
 
Swcwcl:

     Cw_DataEnvi.DataConnect.RollbackTrans
     If Err.Number = -2147217833 Then
         Tsxx = Trim(LrText(0)) & "的位数小于数据表中已有数据的位数!"
     Else
         Tsxx = "存盘过程中出现错误,程序自动恢复保存前状态!"
     End If
     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
       
        '[>>
        '在此处可添加新增记录时初始化设置
        '<<]
    Else
    
        '修改记录时根据记录关键字(编码)从数据表中读入其他字段内容
        With RecTemp
            Sqlstr = "SELECT * FROM Rs_Items Where ItemID=" & Val(Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 0)))

            Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
       
            '记录如存在则读入其内容,否则提示记录已被其他人删除
            If Not RecTemp.EOF Then
                LrText(0).Text = Trim(.Fields("ChName") & "")          '项目名称
                LrText(1).Text = .Fields("FieldLength")                '项目长度
                LrText(2).Text = .Fields("FieldDotL")                  '小数位数
            Else
                Tsxx = "该记录已经被其他人删除,请刷新当前数据!"
                Call Xtxxts(Tsxx, 0, 4)
                Call Cancel
                TextChangeLock = False
                Exit Function
            End If
        End With
    End If
    
    Cshlrxx = True
    TextChangeLock = False
    
End Function

Private Sub Scdqjl()                 '删 除 当 前 记 录

    Dim Yhanswer As Integer
    Dim Rsc As New ADODB.Recordset
  
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
         Exit Sub
    End If
    
    '非数据行不能删除
    If CzxsGrid.Row < CzxsGrid.FixedRows Then
        Exit Sub
    End If
    
    With CzxsGrid
        If Trim(.TextMatrix(.Row, Sydz("004", GridStr(), Szzls))) = True Then
            Call Xtxxts("固定项目不能删除!", 0, 1)
            Exit Sub
        End If
    End With
    '用户确认是否删除记录
    Tsxx = "请确认是否删除当前记录?"
    Yhanswer = Xtxxts(Tsxx, 2, 2)
    
    If Yhanswer = 2 Then
        Exit Sub
    End If

    

    '[>>以下需自定义部分
    '当类别项目表中引用工资项目时，该工资项目不可删除。
    If sID = 3 Then
        If Rsc.State = 1 Then Rsc.Close
        Set Rsc = Cw_DataEnvi.DataConnect.Execute("select * from Pm_SortItem where ItemId=" & CzxsGrid.TextMatrix(CzxsGrid.Row, 0))
        If Not Rsc.EOF Then
           Call Xtxxts(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls)) & "已被工资类别引用，不能删除!", 0, 1)
           Exit Sub
        End If
    End If
    '当公式内容、限定条件、报表的显示项目中使用考勤项目、考勤表中该项目有数据时，该考勤项目不可删除。
    If sID = 4 Then
        With CzxsGrid
            '判断公式内容
            If Rsc.State = 1 Then Rsc.Close
            Sql = "select * from Pm_Formula where charIndex('" & .TextMatrix(.Row, 1) & "',Fcontent,0)<>0 "
            Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sql)
            If Not Rsc.EOF Then
               Call Xtxxts(.TextMatrix(.Row, Sydz("001", GridStr(), Szzls)) & "在公式中用到，不能删除!", 0, 1)
               Exit Sub
            End If
            '判断公式的限定条件
            If Rsc.State = 1 Then Rsc.Close
            Sql = "select * from Pm_Formula where charIndex('" & .TextMatrix(.Row, 1) & "',Flimit,0)<>0 "
            Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sql)
            If Not Rsc.EOF Then
               Call Xtxxts(.TextMatrix(.Row, Sydz("001", GridStr(), Szzls)) & "在公式的限定条件中用到，不能删除!", 0, 1)
               Exit Sub
            End If
            '判断标准表的限定条件
            If Rsc.State = 1 Then Rsc.Close
            Sql = "select * from Pm_StandTbl where charIndex('" & .TextMatrix(.Row, 1) & "',BzbCond,0)<>0 "
            Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sql)
            If Not Rsc.EOF Then
               Call Xtxxts(.TextMatrix(.Row, Sydz("001", GridStr(), Szzls)) & "在标准表的限定条件中用到，不能删除!", 0, 1)
               Exit Sub
            End If
            '判断报表的项目
            If Rsc.State = 1 Then Rsc.Close
            Sql = "select * from Pm_ReportItem where FieldName='" & .TextMatrix(.Row, 1) & "'"
            Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sql)
            If Not Rsc.EOF Then
               Call Xtxxts(.TextMatrix(.Row, Sydz("001", GridStr(), Szzls)) & "在报表的项目中用到，不能删除!", 0, 1)
               Exit Sub
            End If
            '判断考勤表中是否该项目是否有数据
            If Rsc.State = 1 Then Rsc.Close
            Sql = "select * from Pm_AttendRecord where " & .TextMatrix(.Row, 1) & "<>0 "
            Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sql)
            If Not Rsc.EOF Then
               Call Xtxxts(.TextMatrix(.Row, Sydz("001", GridStr(), Szzls)) & "在考勤数据表中有数据，不能删除!", 0, 1)
               Exit Sub
            End If
        End With
    End If
    
    On Error GoTo Cwcl
    
    Cw_DataEnvi.DataConnect.BeginTrans
    Sql = "delete Rs_Items where ItemID = " + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 0))
    Cw_DataEnvi.DataConnect.Execute Sql
    Sql = " alter table " & TableName & " drop constraint  DF_" & CzxsGrid.TextMatrix(CzxsGrid.Row, 1)
    Sql = Sql & " alter table " & TableName & " drop column " & CzxsGrid.TextMatrix(CzxsGrid.Row, 1)
    Cw_DataEnvi.DataConnect.Execute Sql
    '以上为自定义部分<<]
  
    Cw_DataEnvi.DataConnect.CommitTrans

    CzxsGrid.RemoveItem CzxsGrid.Row
    Lbl_Count.Caption = "共" & CzxsGrid.Rows - CzxsGrid.FixedRows & "项"
    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 Form_KeyUp(KeyCode As Integer, Shift As Integer)        '支持热键操作

    If Shift = 2 Then
        Select Case UCase(Chr(KeyCode))
            Case "P"                                                                          'Ctrl+P 打印
                If SzToolbar.Buttons("dy").Visible And SzToolbar.Buttons("dy").Enabled Then
                    Call bbyl(False)
                End If
            Case "A"                                                                          'Ctrl+A 增加
                '判断用户是否有此功能执行权限,如有则写上机日志(进入)
                If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
                    Exit Sub
                End If
                If SzToolbar.Buttons("zj").Visible And SzToolbar.Buttons("zj").Enabled Then
                    Call Toolbjzt
                    Lrzt = 1
                    Call Cshlrxx(Lrzt)
                    LrText(0).SetFocus
                    LrText(0).Enabled = True
                End If
            Case "D"                                                                          'Ctrl+D 删除
                If SzToolbar.Buttons("sc").Visible And SzToolbar.Buttons("sc").Enabled Then
                    Call Scdqjl
                End If
        End Select
    End If
    
End Sub

Private Sub SzToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
   
    Select Case Button.Key
        Case "ymsz"                                          '页面设置
            Dyymctbl.Show 1
        Case "yl"                                            '预 览
            Call bbyl(True)
        Case "dy"                                            '打 印
            Call bbyl(False)
        Case "zj"                                            '增 加
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
                Exit Sub
            End If
            Call Toolbjzt
            Lrzt = 1
            Call Cshlrxx(Lrzt)
            LrText(0).Enabled = True
            LrText(1).Enabled = True
            LrText(0).SetFocus
        Case "xg"                                            '修 改
            Call Xgdqjl
        Case "sc"                                            '删 除
            Call Scdqjl
        Case "sx"                                            '刷 新
            Call Cxnrtcwg
        Case "bz"                                            '帮 助
            Call F1bz
        Case "fh"                                            '退 出
            Unload Me
        End Select
        
End Sub

Private Sub CzxsGrid_DblClick()                            '修改当前编码记录

    Call Xgdqjl
  
End Sub