+

VB开发的ERP系统

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

Private Function Bclrsj() As Boolean                   '判断录入数据有效性,并保存数据
  
    Dim jsqte As Integer
    Dim sSql As String
    '对文本框录入内容进行为零和为空判断(固定不变)
    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 Lrzt = 1 Then  '增 加
            
        Else  '否则为修改记录
 
            On Error GoTo Swcwcl
            DptAmount = Val(Trim(LrText(0).Text)) - DptAmount
            
            Cw_DataEnvi.DataConnect.BeginTrans
            sSql = "UPDATE Gy_department SET amount = amount + " & DptAmount & " WHERE  deptcode= LEFT('" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 0)) & "',len(rtrim(deptcode)))"
            Cw_DataEnvi.DataConnect.Execute (sSql)

            Cw_DataEnvi.DataConnect.CommitTrans
       
            '刷新当前网格
            Call Cxnrtcwg
            Call Xtxxts("保存成功!", 0, 4)
   
        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 Gy_Department Where DeptCode='" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 0)) & "'"
            Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
            '记录如存在则读入其内容,否则提示记录已被其他人删除
            If Not RecTemp.EOF Then
                Lbl_DeptName.Caption = Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls)))
                LrText(0).Text = Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("002", GridStr(), Szzls)))           '部门编码
                DptAmount = LrText(0).Text
                LrText(0).Tag = Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, 0))

            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 aDo_Rec As New Recordset
    '非数据行不能删除
    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 aDo_Rec = Cw_DataEnvi.DataConnect.Execute("select * from Gy_Department where ParentCode='" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) & "'")
    If aDo_Rec.RecordCount > 0 Then
        aDo_Rec.Close
        Tsxx = "该项有下级,不能删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
    aDo_Rec.Close
  
  On Error GoTo Cwcl
      
    Cw_DataEnvi.DataConnect.BeginTrans
 
    '[>>以下需自定义部分
    Cw_DataEnvi.DataConnect.Execute "delete Gy_Department where DeptCode = '" + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) + "'"
 
  
    Add_Tree
    '以上为自定义部分<<]
  
    Cw_DataEnvi.DataConnect.CommitTrans
  
    '将记录加入网格
    '  Call Cxnrtcwg
    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 DBIni() As Boolean
'每次使用定员设置首先保证定员设置表中的部门与公用部门表里的同步
Dim tmpRs As New ADODB.Recordset
Dim sSql As String


    
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 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 imgSplitter_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    With imgSplitter
        picSplitter.Move .Left, .Top, .Width \ 2, .Height - 20
    End With
    picSplitter.Visible = True
    mbMoving = True

End Sub

Private Sub imgSplitter_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    Dim sglPos As Single
    If mbMoving Then
        sglPos = x + imgSplitter.Left
        If sglPos < sglSplitLimit Then
            picSplitter.Left = sglSplitLimit
        ElseIf sglPos > Me.Width - sglSplitLimit Then
            picSplitter.Left = Me.Width - sglSplitLimit
        Else
            picSplitter.Left = sglPos
        End If
    End If

End Sub

Private Sub imgSplitter_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    SizeControls picSplitter.Left
    picSplitter.Visible = False
    mbMoving = False
   ' StTab.Refresh

End Sub

Sub SizeControls(x As Single)
    
    On Error Resume Next

    '设置 Width 属性
    If x < 2000 Then x = 2000
    If x > (Me.Width - 5000) Then x = Me.Width - 5000
    TrV_Depart.Width = x - 100
    imgSplitter.Left = x
    StTab.Left = x + 40
    StTab.Width = Me.Width - (TrV_Depart.Width + 300)
    '设置 Top 属性
    TrV_Depart.Top = tbToolBar.Height + picTitles.Height
    StTab.Top = TrV_Depart.Top
    Dim St_tab As Integer
    St_tab = StTab.Tab
    StTab.Tab = 0
    CzxsGrid.Width = StTab.Width - CzxsGrid.Left * 2
    StTab.Tab = St_tab
    imgSplitter.Top = TrV_Depart.Top
    imgSplitter.Height = TrV_Depart.Height

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 "xg"                                            '修 改
            Call Xgdqjl
        Case "sx"                                            '刷 新
            Call Cxnrtcwg
            Add_Tree
        Case "bz"                                            '帮 助
            Call F1bz
        Case "fh"                                            '退 出
            Unload Me
    End Select

End Sub

Private Sub CzxsGrid_DblClick()                            '修改当前编码记录
    Call Xgdqjl
End Sub

Private Sub Xgdqjl()                                       '修改当前编码记录
    
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True, False) Then
        BcCommand.Enabled = False
    End If
    
    If CzxsGrid.Row < CzxsGrid.FixedRows Then
        Exit Sub
    End If
    If CzxsGrid.CellBackColor = &HFFC0C0 Then Call Xtxxts("不是末级部门，不能修改!", 0, 1): Exit Sub
    Call Toolbjzt
    Lrzt = 2
    If Cshlrxx(Lrzt) Then
        LrText(0).Enabled = True
        LrText(0).SetFocus
        If LrText(0).Text = 0 Then
           LrText(0).Text = ""
        End If
    End If

End Sub

Private Sub Toolbjzt()                                     'Toolbar状态(编辑状态)
    
    StTab.TabEnabled(1) = True
    StTab.Tab = 1
    StTab.TabEnabled(0) = False
    CzxsGrid.Enabled = False
    With SzToolbar
        .Buttons("ymsz").Enabled = False
        .Buttons("dy").Enabled = False
        .Buttons("yl").Enabled = False
        .Buttons("zj").Enabled = False
        .Buttons("xg").Enabled = False
        .Buttons("sc").Enabled = False
        .Buttons("sx").Enabled = False
        .Buttons("fp").Enabled = False
    End With
    TrV_Depart.Enabled = False

End Sub

Private Sub Toolfbjzt()                                    'Toolbar状态(非编辑状态)
    
    StTab.TabEnabled(0) = True
    StTab.Tab = 0
    CzxsGrid.Enabled = True
    StTab.TabEnabled(1) = False
    Lrzt = 0
    With SzToolbar
        .Buttons("ymsz").Enabled = True
        .Buttons("dy").Enabled = True
        .Buttons("yl").Enabled = True
        .Buttons("zj").Enabled = True
        .Buttons("xg").Enabled = True
        .Buttons("sc").Enabled = True
        .Buttons("sx").Enabled = True
        .Buttons("fp").Enabled = True
    End With
    TrV_Depart.Enabled = True

End Sub

Private Sub BcCommand_Click()                                           '保 存
  
    If Not Bclrsj Then
        Exit Sub
    End If
    If Lrzt = 2 Then
        Call Toolfbjzt
    End If
End Sub

Private Sub QxCommand_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)       '取消
    
    '避免执行Click程序
    Bln_Cancel = True