+

VB开发的ERP系统

                Call Xtxxts(Tsxx, 0, 1)
                LrText(0).SetFocus
                Bclrsj = False
                Exit Function
            End If
           
            '判断条件是否互相包含
            Xdtj = ""
            If Not Pdcondstion(Xdtj) Then
                Call Xtxxts(Tsxx, 0, 1)
                LrText(1).SetFocus
                Bclrsj = False
                Exit Function
            End If
    
    
            '判断记录内容无误后,将记录内容写入数据表
            On Error GoTo Swcwcl
    
            Cw_DataEnvi.DataConnect.BeginTrans
   
                .AddNew
                .Fields("whcode") = Trim(LrText(0).Tag)         '仓库
                .Fields("msort") = Trim(LrText(1).Tag)          '存货分类
                .Fields("mnumber") = Trim(LrText(2).Tag)        '存货编码
                .Fields("macct") = Trim(LrText(3).Tag)          '存货科目
                .Fields("diffacct") = Val(LrText(4).Tag)        '差异科目
                .Update
            
            Cw_DataEnvi.DataConnect.CommitTrans
   
            '将记录加入网格
            SqlStr = "SELECT top 1 * FROM Chhs_V_Macc order by MaccId desc"
            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("001", GridStr(), Szzls)
                CzxsGrid.Sort = flexSortStringAscending
            End With
            '<<]
    
        Else  '否则为修改记录
 
            
            '[>>判断条件是否重复
            If .State = 1 Then .Close
            .Open "SELECT * FROM Chhs_Macc " + Xdtj + " and MaccId<> '" + Trim(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
        
            '判断条件是否互相包含
            Xdtj = " and MaccId<> '" + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 0)) + "'"
            If Not Pdcondstion(Xdtj) Then
                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 Chhs_Macc WHERE MaccId= '" + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 0)) + "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
             
            If Not .EOF Then
                .Fields("whcode") = Trim(LrText(0).Tag)         '仓库
                .Fields("msort") = Trim(LrText(1).Tag)          '存货分类
                .Fields("mnumber") = Trim(LrText(2).Tag)        '存货编码
                .Fields("macct") = Trim(LrText(3).Tag)          '存货科目
                .Fields("diffacct") = Val(LrText(4).Tag)        '差异科目
                .Update
            End If
            
            Cw_DataEnvi.DataConnect.CommitTrans
            
            '刷新当前网格
            SqlStr = "SELECT * FROM Chhs_V_Macc WHERE MaccId= '" + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 0)) + "'"
            Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(SqlStr)
            
            If Not Cxnrrec.EOF Then
                With CzxsGrid
                    Call Jltcwg(Cxnrrec, .Row)
                End With
            Else
                Tsxx = "该记录已经被其他人删除,请刷新当前数据!"
                Call Xtxxts(Tsxx, 0, 4)
                Exit Function
            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
       
        '[>>
        '在此处可添加新增记录时初始化设置
        '<<]
    Else
    
        '修改记录时根据记录关键字(编码)从数据表中读入其他字段内容
        With Rectemp
        
            SqlStr = "SELECT * FROM Chhs_V_Macc Where MaccId='" & CzxsGrid.TextMatrix(CzxsGrid.Row, 0) & "'"
            Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
       
            '记录如存在则读入其内容,否则提示记录已被其他人删除
            If Not Rectemp.EOF Then
                LrText(0).Text = Trim(.Fields("whname") & "")              '仓库名称
                LrText(0).Tag = Trim(.Fields("whcode") & "")               '仓库编码
                LrText(1).Text = Trim(.Fields("invsortname") & "")         '存货分类名称
                LrText(1).Tag = Trim(.Fields("msort") & "")                '存货分类编码
                LrText(2).Text = Trim(.Fields("mname") & "")               '存货名称
                LrText(2).Tag = Trim(.Fields("mnumber") & "")              '存货编码
                LrText(3).Text = Trim(.Fields("cname") & "")               '对方科目名称
                LrText(3).Tag = Trim(.Fields("macct") & "")                '对方科目编码
                LrText(4).Text = Trim(.Fields("DiffCname") & "")           '差异科目名称
                LrText(4).Tag = Trim(.Fields("diffacct") & "")             '差异科目编码
            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
  
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    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
  
    Cw_DataEnvi.DataConnect.BeginTrans
  
    '[以下需自定义部分
    Cw_DataEnvi.DataConnect.Execute "delete Chhs_Macc where MaccId = '" + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 0)) + "'"
    '以上为自定义部分]
  
    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 Function Pdcondstion(Cond As String) As Boolean               '判断条件(限定条件）
    Dim SqlStr As String
    Dim Rectemp As Recordset
    Dim FirstSort As String            '鼎级分类
    
    Msg = 0
    Pdcondstion = True
    
    If Trim(LrText(2)) = "" Then
        If Trim(LrText(1)) = "" Then
            SqlStr = "select * from Chhs_Macc where  whcode='" & Trim(LrText(0).Tag) & "' " + Cond
            Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
            If Not Rectemp.EOF Then
                Tsxx = "仓库已对应其它存货科目！"
                Pdcondstion = False
                Exit Function
            End If
        Else
            SqlStr = "select * from Chhs_Macc where  whcode='" & Trim(LrText(0).Tag) & "' and msort like '" & Trim(LrText(1).Tag) & "%'" + Cond
            Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
            If Not Rectemp.EOF Then
                Tsxx = "仓库+存货分类已对应其它的存货科目,或下级分类已设置！"
                Pdcondstion = False
                Exit Function
            Else
                '鼎级编码长度
                SqlStr = "SELECT * FROM Gy_CodeScheme WHERE (ItemCode = 'Kf_KfwlflSet')"
                Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                If Not Rectemp.EOF Then
                   FirstSort = Left(Rectemp.Fields("CodeScheme"), 1)
                   FirstSort = Left(Trim(LrText(1).Tag), Val(FirstSort))
                End If
                
                SqlStr = "select * from Chhs_Macc where  whcode='" & Trim(LrText(0).Tag) & "' and (msort like '" & Trim(FirstSort) & "%' and msort<>'" & Trim(LrText(1).Tag) & "' and len(msort)<>'" & Len(Trim(LrText(1).Tag)) & "') " + Cond
                Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                If Not Rectemp.EOF Then
                    Tsxx = "仓库+存货分类的上级分类已设置，或仓库+存货分类已设置！"
                    Pdcondstion = False
                    Exit Function
                End If
                
                SqlStr = "select * from Chhs_Macc where  whcode='" & Trim(LrText(0).Tag) & "' and  (msort is null or msort='') " + Cond
                Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
                If Not Rectemp.EOF Then
                    Tsxx = "仓库+存货科目已设置！"
                    Pdcondstion = False
                    Exit Function
                End If
                
            End If
        End If
    Else
        SqlStr = "select * from Chhs_Macc where  whcode='" & Trim(LrText(0).Tag) & "'and (msort is null or msort='') and (mnumber is null or mnumber ='') " + Cond
        Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        If Not Rectemp.EOF Then
            Tsxx = "仓库+存货科目已设置!"
            Pdcondstion = False
            Exit Function
        End If
        
        '鼎级编码长度
        SqlStr = "SELECT * FROM Gy_CodeScheme WHERE (ItemCode = 'Kf_KfwlflSet')"
        Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        If Not Rectemp.EOF Then
           FirstSort = Left(Rectemp.Fields("CodeScheme"), 1)
           FirstSort = Left(Trim(LrText(1).Tag), Val(FirstSort))
        End If
        SqlStr = "select * from Chhs_Macc where  whcode='" & Trim(LrText(0).Tag) & "'and msort like '" & Trim(FirstSort) & "%' and (mnumber='' or mnumber is null) " + Cond
        Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        If Not Rectemp.EOF Then
            Tsxx = "仓库+存货分类+存货科目已设置!"
            Pdcondstion = False
            Exit Function
        End If
        
        SqlStr = "select * from Chhs_Macc where  whcode='" & Trim(LrText(0).Tag) & "' and mnumber='" & Trim(LrText(2).Tag) & "'" + Cond
        Set Rectemp = Cw_DataEnvi.DataConnect.Execute(SqlStr)
        If Not Rectemp.EOF Then
            Tsxx = "仓库+存货+存货科目已设置!"
            Pdcondstion = False
            Exit Function
        End If
    End If
End Function

'*******************以上区域为编写自定义过程区域**********************

'*******************************以下为基本处理程序(固定不变)*******************************************'
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