+

VB开发的ERP系统

        .TextMatrix(0, 3) = "结果字段名"
    End With
    Sql = " and czybm='" & Xtczybm & "'"
    ImgCbo_Sort.Text = ""
    Call DynaFillImageCombo(ImgCbo_Sort, "pm_SortEmp", 0, Sql)
    SortId = GetComboKey(ImgCbo_Sort, 0)
    '填 充 网 格
    Call Cxnrtcwg
       
    '初始化toolbar,tab卡状态
    StTab.Tab = 0
    StTab.TabEnabled(1) = False
    Frame1.Enabled = False
    If Rsc.State = 1 Then Rsc.Close
    Sql = "select Distinct CodeLevel from gy_Department where RsPmFlag=1 order by CodeLevel"
    Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sql)
    With Cbo_DeptLevel
        .AddItem ""
        Do While Not Rsc.EOF
            .AddItem (Rsc!CodeLevel)
            Rsc.MoveNext
        Loop
        .Text = ""
    End With
    
    '设置为非录入状态
    Lrzt = 0
    '编辑(新增、修改、删除)权限索引
    Str_RightEdit = "Pm_StandTbl_edit"
End Sub
 
Private Sub Cxnrtcwg()                               '查询内容填充网格

    Dim Sqlstr As String              '查询连接串
    Dim jsqte As Long                 '查询临时使用变量
  
    '为加快显示速度,将网格刷新动作冻结
    CzxsGrid.Redraw = False
  
    '[>>查询连接串
    Sqlstr = "SELECT * FROM PM_StandTBL where SortId='" & SortId & "' order by BzbNO"
    '<<]
    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
    
End Sub

Private Sub Jltcwg(Jlbrec As ADODB.Recordset, Rowjsq As Long)           '记录内容填充网格

    '[>>以下为自定义部分
    With Jlbrec
        CzxsGrid.TextMatrix(Rowjsq, 0) = Trim(.Fields("BzbNO") & "")            '标准表号
        CzxsGrid.TextMatrix(Rowjsq, 1) = Trim(.Fields("BzbHxItem") & "")            '横向字段名
        CzxsGrid.TextMatrix(Rowjsq, 2) = Trim(.Fields("BzbVxItem") & "")            '纵向字段名
        CzxsGrid.TextMatrix(Rowjsq, 3) = Trim(.Fields("BzbResuItem") & "")            '结果字段名
        CzxsGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls)) = Trim(.Fields("BzbName") & "")            '标准表名称
        If Rsc.State = 1 Then Rsc.Close
        Set Rsc = Cw_DataEnvi.DataConnect.Execute("select * from Rs_Items where ltriM(rtrim(tablename)) + '.' + ltrim(rtrim(fieldname))='" & Trim(.Fields("BzbHxItem") & "") & "'")
        If Not Rsc.EOF Then
            CzxsGrid.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls)) = Trim(Rsc!ChName)            '横向项目
        End If
        
        If Rsc.State = 1 Then Rsc.Close
        Set Rsc = Cw_DataEnvi.DataConnect.Execute("select * from Rs_Items where ltriM(rtrim(tablename)) + '.' + ltrim(rtrim(fieldname))='" & Trim(.Fields("BzbVxItem") & "") & "'")
        If Not Rsc.EOF Then
            CzxsGrid.TextMatrix(Rowjsq, Sydz("003", GridStr(), Szzls)) = Trim(Rsc!ChName)            '纵向项目
        End If
        
        If Rsc.State = 1 Then Rsc.Close
        Set Rsc = Cw_DataEnvi.DataConnect.Execute("select * from Rs_Items where FieldName='" & Trim(.Fields("BzbResuItem") & "") & "'")
        If Not Rsc.EOF Then
            CzxsGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls)) = Trim(Rsc!ChName)            '结果项目
        End If
        
        CzxsGrid.TextMatrix(Rowjsq, Sydz("005", GridStr(), Szzls)) = .Fields("BzbUnEnable")             '有效
        
        If .Fields("CodeLevel") = 0 Then
            CzxsGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls)) = ""               '部门级别
        Else
            CzxsGrid.TextMatrix(Rowjsq, Sydz("006", GridStr(), Szzls)) = .Fields("CodeLevel") & ""
        End If
    End With
    '以上为自定义部分<<]
    
End Sub

Private Sub Form_Unload(Cancel As Integer)             '窗体卸载

    Set Cxnrrec = Nothing
    Set Rec_CodeSet = Nothing
    Set Rsc = Nothing
    Unload Dyymctbl
   
End Sub

Private Function Bclrsj() As Boolean                   '判断录入数据有效性,并保存数据

    Dim jsqte As Integer
    Dim BzbNO 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 Trim(SortId) = "" Then
            Call Xtxxts("工资类别不能空!", 0, 1)
            Exit Function
        End If
        If LCase(Trim(LrText(1).Tag)) = "rs_basicinfo.deptcode" Or LCase(Trim(LrText(2).Tag)) = "rs_basicinfo.deptcode" Then
            If Trim(Cbo_DeptLevel.Text) = "" Then
                Call Xtxxts("部门级别不能空!", 0, 1)
                Exit Function
            End If
        Else
            If Trim(Cbo_DeptLevel.Text) <> "" Then
                Call Xtxxts("部门级别必须空!", 0, 1)
                Exit Function
            End If
        End If
        '横向项目、纵向项目必须是有相关项明细的项目
        If LCase(Trim(LrText(1).Tag)) <> "rs_basicinfo.deptcode" And LCase(Trim(LrText(2).Tag)) <> "rs_basicinfo.deptcode" Then
            If Rsc.State = 1 Then Rsc.Close
            Sql = "select distinct FieldName,ChName,ItemID from Rs_Items i" & _
                  " inner join Rs_CorMain  m on" & _
                  " i.CorreLation =m.SortId inner join Rs_CorSub s on " & _
                  " m.SortID=s.SortID Where ltriM(rtrim(tablename)) + '.' + ltrim(rtrim(fieldname))='" & Trim(LrText(1).Tag) & "'"
            Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sql)
            If Rsc.EOF Then
                Call Xtxxts("横向项目“" & Trim(LrText(1)) & "”不存在相关项，不能建立标准表!", 0, 1)
                Exit Function
            End If
            
            If Trim(LrText(2).Text) <> "" Then
                If Rsc.State = 1 Then Rsc.Close
                Sql = "select distinct FieldName,ChName,ItemID from Rs_Items i" & _
                      " inner join Rs_CorMain  m on" & _
                      " i.CorreLation =m.SortId inner join Rs_CorSub s on " & _
                      " m.SortID=s.SortID Where ltriM(rtrim(tablename)) + '.' + ltrim(rtrim(fieldname))='" & Trim(LrText(2).Tag) & "'"
                Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sql)
                If Rsc.EOF Then
                    Call Xtxxts("纵向项目“" & Trim(LrText(2)) & "”不存在相关项，不能建立标准表!", 0, 1)
                    Exit Function
                End If
            End If
        End If
        
        '结果项目必须是本类别的工资项目。
        If Trim(LrText(3).Tag) = "" Then
            Call Xtxxts("请按按钮选择工资项目! ", 0, 1)
            Exit Function
        End If
        
        If Lrzt = 1 Then  '增 加
        
            '[>>

            '判断名称是否重复
            If .State = 1 Then .Close
            .Open "SELECT * FROM PM_StandTbl WHERE BzbName= '" + 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
            If Rsc.State = 1 Then Rsc.Close
            Set Rsc = Cw_DataEnvi.DataConnect.Execute("select * from PM_StandTbl order by BzbNO desc")
            If Not Rsc.EOF Then
                BzbNO = Rsc!BzbNO + 1
            Else
                BzbNO = 1
            End If
            '判断记录内容无误后,将记录内容写入数据表
            On Error GoTo Swcwcl
    
            Cw_DataEnvi.DataConnect.BeginTrans
   
            .AddNew
            .Fields("BzbNO") = BzbNO    '标准号
            .Fields("SortId") = SortId                   '工资类别号
            .Fields("BzbName") = Trim(LrText(0).Text)    '标准表名
            .Fields("BzbHxItem") = Trim(LrText(1).Tag)     '横向字段名
            .Fields("BzbVxItem") = Trim(LrText(2).Tag)    '纵向字段名
            .Fields("BzbResuItem") = Trim(LrText(3).Tag)    '结果字段名
            If Trim(Cbo_DeptLevel.Text) = "" Then
                .Fields("CodeLevel") = 0
            Else
                 .Fields("CodeLevel") = Trim(Cbo_DeptLevel.Text) '部门级别
            End If
            .Fields("BzbUnEnable") = Chk_UnEnable.Value     '有效
            .Update
            
            Cw_DataEnvi.DataConnect.CommitTrans

            '将记录加入网格
            Sqlstr = "SELECT * FROM PM_StandTbl WHERE BzbNo= " & BzbNO
            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 = flexSortStringAscending
            End With
            
            '<<]
    
        Else  '否则为修改记录
 
            If .State = 1 Then .Close
            .Open "SELECT * FROM PM_StandTbl WHERE BzbName= '" & Trim(LrText(0).Text) & "' and BzbNO<>" & Val(CzxsGrid.TextMatrix(CzxsGrid.Row, 0)), 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 .State = 1 Then .Close
            .Open "SELECT * FROM PM_StandTbl WHERE BzbName= '" + Trim(LrText(0).Text) + "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
     
            If Not .EOF Then
                .Fields("BzbUnEnable") = Chk_UnEnable    '无效
                .Update
            End If

             Cw_DataEnvi.DataConnect.CommitTrans
   
            '刷新当前网格
            Sqlstr = "SELECT * FROM PM_StandTbl WHERE BzbName= '" + Trim(LrText(0).Text) + "'"
            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
     
     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