VB开发的ERP系统

                Dim i As Integer
                For i = 0 To Combo1.ListCount - 1
                    Combo1.ListIndex = i
                    If Combo1.Text = Trim(.Fields("DeptProp") & "") Then Exit For
                Next
            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 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 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
  
    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 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 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

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
    TreeView.Width = X - 100
    imgSplitter.Left = X
    StTab.Left = X + 40
    StTab.Width = Me.Width - (TreeView.Width + 300)
    '设置 Top 属性
    StTab.Top = TreeView.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 = TreeView.Top
    imgSplitter.Height = TreeView.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 "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 "fp"                                            '分配
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log("Gy_Department_Allot", Xtczybm, 1, True) Then
                Exit Sub
            End If
            Gy_DeptAllot.HelpContextID = 331200101
            Gy_DeptAllot.Show 1
            Call Cxnrtcwg
        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
    Call Toolbjzt
    Lrzt = 2
    If Cshlrxx(Lrzt) Then
        LrText(1).SetFocus
        LrText(0).Enabled = False
    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
    TreeView.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
    TreeView.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
  
    Call Cancel

End Sub

Private Sub QxCommand_Click()                                                                         '取消
    
    If Bln_Cancel Then
        Bln_Cancel = False
        Exit Sub
    End If
 
    Call Cancel

End Sub

Private Sub Cancel()                                                                                  '取消
    
    '文本框加锁
    For jsqte = 0 To Max_Text_Index
        TextValiJudgeLock(jsqte) = True
    Next jsqte
  
    Call Toolfbjzt

End Sub

Private Sub CzxsGrid_AfterMoveColumn(ByVal Col As Long, Position As Long)           '网格列发生移动时自动交换网格索引信息
    FnBln_RefreshArray Col, Position, GridStr(), GridInf()
End Sub

Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)   '表格格式设置(通用)
    
    Select Case Button.Key
        Case "bcgs"                                       '保存表格格式
            Call Bcwggs(CzxsGrid, GridCode, GridStr())
        Case "hfmrgs"                                     '恢复默认格式
            Call Hfmrgs(CzxsGrid, GridCode, GridStr())
        Case "szxsxm"                                     '设置显示项目
            Call Szxsxm(CzxsGrid, GridCode)
    End Select

End Sub

Private Sub bbyl(bbylte As Boolean)                    '报表打印预览