+

VB开发的ERP系统

                Exit Function
            End If
        End If
        
        '对需要进行事后判断的文本框录入内容进行有效性判断 (固定不变)
        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  '增 加
            
            '判断项目编码是否符合规则 , 如有效则同时计算项目级次和上级项目编码
            For Jsqte = 1 To Int_CodeLev
                If Int_CodeScheme(Jsqte) = Len(Trim(LrText(0).Text)) Then
                    CodeLev = Jsqte
                    Exit For
                End If
            Next Jsqte
            If Jsqte <= CodeLev Then
                If Jsqte > 1 Then
                    Str_Parent = Mid(Trim(LrText(0).Text), 1, Int_CodeScheme(Jsqte - 1))
                Else
                    Str_Parent = ""
                End If
            Else
                Tsxx = "项目编码不符合编码规则!"
                Call Xtxxts(Tsxx, 0, 1)
                LrText(0).SetFocus
                Bclrsj = False
                Exit Function
            End If
            
            '判断此项目是否已建立上级项目
            If Str_Parent <> "" Then
                Set Rec_CodeSet = Cw_DataEnvi.DataConnect.Execute("SELECT ItemCode FROM Cwzz_Item  Where ItemCode='" & Trim(Str_Parent) & "' and ItemClassCode='" & Str_ClassCode & "'")
                If Rec_CodeSet.EOF Then
                    Tsxx = "请先建立其上级项目编码!"
                    Call Xtxxts(Tsxx, 0, 1)
                    LrText(0).Text = Str_Parent
                    LrText(0).SelStart = Len(LrText(0).Text)
                    LrText(0).SetFocus
                    Bclrsj = False
                    Exit Function
                End If
                Set RecTemp = Cw_DataEnvi.DataConnect.Execute("SELECT Top 1 ItemCode FROM Cwzz_AccVouchSub Where ItemCode='" & Trim(Str_Parent) & "'")
                If Not RecTemp.EOF Then
                    Tsxx = "项目编码(" + Str_Parent + ")已使用,不能建立下级项目!"
                    Call Xtxxts(Tsxx, 0, 1)
                    LrText(0).SelStart = Len(LrText(0).Text)
                    LrText(0).SetFocus
                    Bclrsj = False
                    Exit Function
                End If
            End If
            
            If .State = 1 Then .Close
            .Open "SELECT * FROM Cwzz_Item WHERE ItemCode= '" & Trim(LrText(0).Text) & "' and ItemClassCode='" & Str_ClassCode & "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
            If Not .EOF Then
                Tsxx = "项目编码重复!"
                Call Xtxxts(Tsxx, 0, 1)
                LrText(0).SetFocus
                Bclrsj = False
                Exit Function
            End If
            
            If .State = 1 Then .Close
            .Open "SELECT * FROM Cwzz_Item WHERE ItemName= '" & Trim(LrText(1).Text) & "' and ItemClassCode='" & Str_ClassCode & "' and ParentCode='" & Str_Parent & "'", 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
            
            .AddNew
            .Fields("ItemClassCode") = Str_ClassCode       '项目类别
            .Fields("ParentCode") = Str_Parent             '上级项目编码
            .Fields("ItemCode") = Trim(LrText(0).Text)     '项目编码
            .Fields("ItemName") = Trim(LrText(1).Text)     '项目名称
            .Fields("Cgrade") = CodeLev                    '项目级次
            If Chk_QuatFlag.Value = 1 Then                 '数量单位
                .Fields("QuantityFlag") = 1
                .Fields("Measure") = Trim(LrText(2).Text)
            Else
                .Fields("QuantityFlag") = 0
                .Fields("Measure") = ""
            End If
            
            .Fields("EndFlag") = 1                         '末级标志
            .Update
            Cw_DataEnvi.DataConnect.CommitTrans
            
            '将记录加入网格
            Sqlstr = "Select * From Cwzz_Item Where ItemCode='" & Trim(LrText(0)) & "' and ItemClassCode='" & Str_ClassCode & "'"
            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 = Sydz("002", GridStr(), Szzls)
                CzxsGrid.Sort = flexSortStringAscending
            End With
            '<<]
            
        Else  '否则为修改记录
            
            Set RecTemp = Cw_DataEnvi.DataConnect.Execute("Select ParentCode From Cwzz_Item  Where ItemCode='" & Trim(LrText(0)) & "' and ItemClassCode='" & Str_ClassCode & "'")
            If Not RecTemp.EOF Then
                Str_Parent = Trim(RecTemp.Fields("ParentCode") & "")
            Else
                Str_Parent = ""
            End If
            
            If .State = 1 Then .Close
            .Open "SELECT * FROM Cwzz_Item WHERE ItemName= '" & Trim(LrText(1).Text) & "' and ItemCode<>'" & Trim(LrText(0).Text) & "' and ItemClassCode='" & Str_ClassCode & "' and ParentCode='" & Str_Parent & "'", 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 .State = 1 Then .Close
            .Open "SELECT * FROM Cwzz_Item WHERE ItemCode= '" & Trim(LrText(0).Text) & "' and ItemClassCode='" & Str_ClassCode & "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
            If Not .EOF Then
                .Fields("ItemName") = Trim(LrText(1).Text)     '项目名称
                If Chk_QuatFlag.Value = 1 Then                 '数量单位
                    .Fields("QuantityFlag") = 1
                    .Fields("Measure") = Trim(LrText(2).Text)
                Else
                    .Fields("QuantityFlag") = 0
                    .Fields("Measure") = ""
                End If
                .Update
            End If
            
            Sqlstr = "Select * From Cwzz_Item Where ItemCode='" & Trim(LrText(0)) & "' and ItemClassCode='" & Str_ClassCode & "'"
            Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
            If Not Cxnrrec.EOF Then
                With CzxsGrid
                    Call Jltcwg(Cxnrrec, .Row)
                End With
            End If
            
        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
        
        Chk_QuatFlag.Value = 0
        
        '[>>
        '在此处可添加新增记录时初始化设置
        '<<]
        
    Else
        
        '修改记录时根据记录关键字(编码)从数据表中读入其他字段内容
        With RecTemp
            Sqlstr = "Select * From Cwzz_Item Where ItemCode='" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("002", GridStr(), Szzls))) & "' and ItemClassCode='" & Str_ClassCode & "'"
            
            Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
            
            '记录如存在则读入其内容,否则提示记录已被其他人删除
            If Not RecTemp.EOF Then
                LrText(0).Text = Trim(RecTemp.Fields("ItemCode"))
                LrText(1).Text = Trim(RecTemp.Fields("ItemName"))
                If RecTemp.Fields("QuantityFlag") Then
                    Chk_QuatFlag.Value = 1
                Else
                    Chk_QuatFlag.Value = 0
                End If
                LrText(2).Text = Trim(RecTemp.Fields("Measure") & "")
                
            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 Str_Parent As String           '上级项目编码
    
    
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) 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
    
    '判断此项目是否存在下级项目,如存在则提示不能删除
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute("Select ItemCode From Cwzz_Item  Where ParentCode='" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("002", GridStr(), Szzls))) & "' and ItemClassCode='" & Str_ClassCode & "'")
    If Not RecTemp.EOF Then
        Tsxx = "此项目存在下级项目,不能删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
    
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute("Select ParentCode From Cwzz_Item  Where ItemCode='" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("002", GridStr(), Szzls))) & "' and ItemClassCode='" & Str_ClassCode & "'")
    If Not RecTemp.EOF Then
        Str_Parent = Trim(RecTemp.Fields("ParentCode") & "")
    End If
    
    On Error GoTo Cwcl
    
    Cw_DataEnvi.DataConnect.BeginTrans
    
    '[以下需自定义部分
    Cw_DataEnvi.DataConnect.Execute "delete Cwzz_Item where ItemCode = '" + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("002", GridStr(), Szzls))) + "' and ItemClassCode='" & Str_ClassCode & "'"
    '以上为自定义部分]
    
    '依情况修改上级项目末级标志
    If Str_Parent <> "" Then
        Set RecTemp = Cw_DataEnvi.DataConnect.Execute("Select ItemCode From Cwzz_Item  Where ParentCode='" & Str_Parent & "' and ItemClassCode='" & Str_ClassCode & "'")
        If RecTemp.EOF Then
            Set RecTemp = Cw_DataEnvi.DataConnect.Execute("Update Cwzz_Item Set Endflag=1 Where ItemCode='" & Trim(Str_Parent) & "' and ItemClassCode='" & Str_ClassCode & "'")
        End If
    End If
    
    Cw_DataEnvi.DataConnect.CommitTrans
    
    CzxsGrid.RemoveItem CzxsGrid.Row
    
    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 Chk_QuatFlag_Click()           '单击数量核算标志
    If Chk_QuatFlag.Value = 1 Then
        Call Textyx(LrText(2))
    Else
        Call Textwx(LrText(2))
    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).Enabled = True
                LrText(0).SetFocus
            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(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