+

VB开发的ERP系统

        CzxsGrid.Clear 1
        CzxsGrid.Rows = .RecordCount + CzxsGrid.FixedRows
        If .EOF And .BOF Then
            Exit Sub
        End If
        jsqte = CzxsGrid.FixedRows
        Do While Not .EOF
            If jsqte >= CzxsGrid.Rows Then
                CzxsGrid.AddItem ""
            End If
            Call Jltcwg(Cxnrrec, jsqte)
            CzxsGrid.RowHeight(jsqte) = Sjhgd
            .MoveNext
            jsqte = jsqte + 1
        Loop
    End With
End Sub
Private Sub Jltcwg(Jlbrec As ADODB.Recordset, Rowjsq As Long)                                       '记录内容填充网格
    '[以下为自定义部分
    With Jlbrec
        CzxsGrid.TextMatrix(Rowjsq, Sydz("001", GridStr(), Szzls)) = Trim(.Fields("CenterCode"))                  '编码
        CzxsGrid.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls)) = Trim(.Fields("CenterName"))                  '名称
        CzxsGrid.TextMatrix(Rowjsq, Sydz("003", GridStr(), Szzls)) = Trim(.Fields("Note") & "") & ""              '备注
    End With
    '以上为自定义部分]
End Sub
Private Sub Form_Unload(Cancel As Integer)             '窗体卸载
    Set Cxnrrec = Nothing
    Unload Dyymctbl
End Sub
Private Function Bclrsj() As Boolean                   '判断录入数据有效性,并保存数据
    Dim jsqte As Integer
    Bclrsj = False
    '文本检查
    With RecSettlement
    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
  
    On Error GoTo Swcwcl
    If Lrzt = 1 Then  '增 加
        '正误判断
        If Len(Trim(LrText(0))) <> 2 Then
            Tsxx = "请录入二位成本中心编码!"
            Call Xtxxts(Tsxx, 0, 1)
            LrText(0).SetFocus
            Bclrsj = False
            Exit Function
        End If
        
        SqlStr = "SELECT * FROM Cb_CostCenter WHERE CenterCode= '" + Trim(LrText(0).Text) + "'"
        Set RecSettlement = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        If Not RecSettlement.EOF Then
            Tsxx = "成本中心编码重复!"
            Call Xtxxts(Tsxx, 0, 1)
            LrText(0).SetFocus
            Bclrsj = False
            Exit Function
        End If
        
        SqlStr = "SELECT * FROM Cb_CostCenter WHERE CenterName= '" + Trim(LrText(1).Text) + "'"
        Set RecSettlement = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        If Not RecSettlement.EOF Then
            Tsxx = "成本中心名称重复!"
            Call Xtxxts(Tsxx, 0, 1)
            LrText(1).SetFocus
            Bclrsj = False
            Exit Function
        End If
        '写入数据
        If .State = 1 Then .Close
        SqlStr = "Select * From Cb_CostCenter Where 1=2"
        .Open SqlStr, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        .AddNew
        .Fields("CenterCode") = Trim(LrText(0).Text)        '成本中心编码
        .Fields("CenterName") = Trim(LrText(1).Text)        '成本中心名称
        .Fields("Note") = Trim(LrText(2).Text)              '备注
        .Update
        
        '显示数据
        SqlStr = "Select * From Cb_CostCenter Where CenterCode='" + Trim(LrText(0).Text) + "'"
        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
        
    Else
        '正误判断
        SqlStr = "SELECT * FROM Cb_CostCenter WHERE CenterName= '" + Trim(LrText(1).Text) + "' And CenterCode<>'" + Trim(LrText(0).Text) + "'"
        Set RecSettlement = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        If Not RecSettlement.EOF Then
            Tsxx = "成本中心名称重复!"
            Call Xtxxts(Tsxx, 0, 1)
            LrText(1).SetFocus
            Bclrsj = False
            Exit Function
        End If
        '写入数据
        If .State = 1 Then .Close
        SqlStr = "SELECT * FROM Cb_CostCenter WHERE CenterCode= '" + Trim(LrText(0).Text) + "'"
        .Open SqlStr, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            .Fields("CenterName") = Trim(LrText(1).Text)        '成本中心名称
            .Fields("Note") = Trim(LrText(2).Text)              '备注
            .Update
        End If
        '显示数据
        SqlStr = "SELECT * FROM Cb_CostCenter WHERE CenterCode= '" + Trim(LrText(0).Text) + "'"
        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:
     Tsxx = "存盘过程中出现错误,请退出后重新进入!"
     Call Xtxxts(Tsxx, 0, 1)
     Exit Function
     
End Function
Private Sub Cshlrxx(lrztxx As Integer)              '初始化录入字段信息

    TextChangeLock = True       '关闭Chang事件
    If lrztxx = 1 Then
    
        For jsqte = 0 To Max_Text_Index
            If Len(Trim(Textstr(jsqte, 1))) <> 0 Then
                TextChangeLock = True
                LrText(jsqte).Text = ""
                LrText(jsqte).Tag = ""
                TextChangeLock = False
            End If
            TextValiJudgeLock(jsqte) = True
        Next jsqte
        
    Else
    
        With CzxsGrid
            LrText(0).Text = Trim(.TextMatrix(.Row, Sydz("001", GridStr(), Szzls)))     '成本中心代码
            LrText(1).Text = Trim(.TextMatrix(.Row, Sydz("002", GridStr(), Szzls)))     '成本中心名称
            LrText(2).Text = Trim(.TextMatrix(.Row, Sydz("003", GridStr(), Szzls)))     '备注
        End With
    End If
    
    TextChangeLock = False
    
End Sub
Private Sub Scdqjl()                 '删 除 当 前 记 录
    Dim yhAnswer As Integer
    
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    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
    
    On Error GoTo Cwcl
  
    '[以下需自定义部分
    '判断是否能够删除
    SqlStr = "Select Count(*) From Cb_CostObject Where CenterCode= '" + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) + "'"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    If RecTemp.Fields(0) > 0 Then
        Tsxx = "该成本中心已经被使用,不能删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
  
    SqlStr = "Select Count(*) From Cb_CostStructure Where CenterCode= '" + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) + "'"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    If RecTemp.Fields(0) > 0 Then
        Tsxx = "该成本中心已经被使用,不能删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
  
    Cw_DataEnvi.DataConnect.Execute "Delete Cb_CostCenter where  CenterCode = '" + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) + "'"
    '以上为自定义部分]
    
    CzxsGrid.RemoveItem CzxsGrid.Row
    Exit Sub
Cwcl:
    If Err.Number = -2147217900 Then
        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 打印
                Call bbyl(False)
            Case "I"                   'Ctrl+I 增加
                '判断用户是否有此功能执行权限,如有则写上机日志(进入)
                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 "D"                   'Ctrl+D 删除
                Call Scdqjl
        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