+

VB开发的ERP系统

    Lrzt = 0
    
    '编辑(新增、修改、删除)权限索引
    Str_RightEdit = "Cb_CostItem_Edit"
 End Sub
Private Sub Cxnrtcwg()                               '查询内容填充网格
    Dim SqlStr As String
    Dim jsqte As Long
  
    '查询连接串
    SqlStr = "Select A.ItemCode,A.ItemName,A.PlanUnitPrice,B.UnitName,A.Note  From Cb_CostItem A " _
                & "Left Outer Join Gy_UnitSet B On B.UnitCode=A.MeasureUnit Order By A.ItemCode"

    Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(SqlStr)
    With Cxnrrec
        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("ItemCode") & "")           '项目编码
        CzxsGrid.TextMatrix(Rowjsq, Sydz("002", GridStr(), Szzls)) = Trim(.Fields("ItemName") & "")           '项目名称
        CzxsGrid.TextMatrix(Rowjsq, Sydz("003", GridStr(), Szzls)) = Trim(.Fields("UnitName") & "")           '计量单位
        CzxsGrid.TextMatrix(Rowjsq, Sydz("004", GridStr(), Szzls)) = Trim(.Fields("PlanUnitPrice") & "")      '计划单价
        CzxsGrid.TextMatrix(Rowjsq, Sydz("005", 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))) <> 3 Then
            Tsxx = "请录入三位成本项目编码!"
            Call Xtxxts(Tsxx, 0, 1)
            LrText(0).SetFocus
            Bclrsj = False
            Exit Function
        End If
        SqlStr = "SELECT * FROM Cb_CostItem WHERE ItemCode= '" + 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_CostItem WHERE ItemName= '" + 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_CostItem Where 1=2"
        .Open SqlStr, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        .AddNew
        .Fields("ItemCode") = Trim(LrText(0).Text)                '项目编码
        .Fields("ItemName") = Trim(LrText(1).Text)                '项目名称
        SqlStr = "Select UnitCode From Gy_UnitSet Where UnitName='" + Trim(LrText(2).Text) + "'"
        Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        If Cxnrrec.EOF Then
            .Fields("MeasureUnit") = ""                           '计量单位
        Else
            .Fields("MeasureUnit") = Cxnrrec.Fields("UnitCode")   '计量单位
        End If
        If Trim(LrText(3).Text) <> "" Then
            .Fields("PlanUnitPrice") = Trim(LrText(3).Text)       '计划单价
        Else
            .Fields("PlanUnitPrice") = 0                          '计划单价
        End If
        .Fields("Note") = Trim(LrText(4).Text)                    '备注
        .Update
        '显示数据
        SqlStr = "Select A.ItemCode,A.ItemName,A.PlanUnitPrice,B.UnitName,A.Note  From Cb_CostItem A " _
                    & "Left Outer Join Gy_UnitSet B On B.UnitCode=A.MeasureUnit " _
                    & "Where A.ItemCode='" + 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_CostItem WHERE ItemName= '" + Trim(LrText(1).Text) + "' And ItemCode<>'" + 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_CostItem WHERE ItemCode= '" + Trim(LrText(0).Text) + "'"
        .Open SqlStr, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
        If Not .EOF Then
            .Fields("ItemName") = Trim(LrText(1).Text)                '项目名称
            SqlStr = "Select UnitCode From Gy_UnitSet Where UnitName='" + Trim(LrText(2).Text) + "'"
            Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(SqlStr)
            If Cxnrrec.EOF Then
                .Fields("MeasureUnit") = ""                           '计量单位
            Else
                .Fields("MeasureUnit") = Cxnrrec.Fields("UnitCode")   '计量单位
            End If
            If Trim(LrText(3).Text) = "" Then
                .Fields("PlanUnitPrice") = 0                          '计划单价
            Else
                .Fields("PlanUnitPrice") = Trim(LrText(3).Text)       '计划单价
            End If
            .Fields("Note") = Trim(LrText(4).Text)                    '备注
            .Update
        End If
        '显示数据
        SqlStr = "Select A.ItemCode,A.ItemName,A.PlanUnitPrice,B.UnitName,A.Note  From Cb_CostItem A " _
                    & "Left Outer Join Gy_UnitSet B On B.UnitCode=A.MeasureUnit " _
                    & "Where A.ItemCode='" + 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)))     '计量单位
            LrText(3).Text = Trim(.TextMatrix(.Row, Sydz("004", GridStr(), Szzls)))     '计划单价
            LrText(4).Text = Trim(.TextMatrix(.Row, Sydz("005", 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_CostStructure  Where ItemCode= '" + 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_CostItem where  ItemCode = '" + 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