VB开发的ERP系统

                    Case "平均年限法(依帐面原值计提折旧)"
                        .Fields("DeprMethod") = "03"
                    Case "工作量法"
                        .Fields("DeprMethod") = "04"
                    Case "固定折旧额折旧法"
                        .Fields("DeprMethod") = "05"
                    Case "年数总和法"
                        .Fields("DeprMethod") = "06"
                    Case "双倍余额法"
                        .Fields("DeprMethod") = "07"
                End Select
                .Fields("UseYears") = Val(LrText(2).Text)
                .Fields("SalvageRate") = Val(LrText(3).Text)
                .Fields("DeprRate") = Val(LrText(4).Text)
                .Update
            End If
            
            Cw_DataEnvi.DataConnect.CommitTrans
            Add_Tree
   
            '刷新当前网格
            Sqlstr = "SELECT * FROM Gdzc_Sort WHERE FaSortCode= '" + Trim(LrText(0).Text) + "'"
            Set Cxnrrec = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
            With CzxsGrid
                Call Jltcwg(Cxnrrec, .Row)
            End With
            Call Cshlrxx(1)
            Call Cancel
            Exit Function
        End If
     
        '保存记录成功,函数返回真值
        Bclrsj = True
        Exit Function
    End With
 
Swcwcl:
    Tsxx = "存盘过程中出现错误,程序自动恢复保存前状态!"
    Call Xtxxts(Tsxx, 0, 1)
    Cw_DataEnvi.DataConnect.RollbackTrans
    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 Gdzc_Sort Where FaSortCode='" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) & "'"
            Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
            '记录如存在则读入其内容,否则提示记录已被其他人删除
            If Not RecTemp.EOF Then
                LrText(0).Text = Trim(.Fields("FaSortCode") & "")            '资产类别编码
                LrText(1).Text = Trim(.Fields("FaSortName") & "")            '资产类别名称
                LrText(2).Text = Trim(.Fields("UseYears") & "")              '使用年限
                LrText(3).Text = Trim(.Fields("SalvageRate") & "")           '残值率
                LrText(4).Text = Trim(.Fields("DeprRate") & "")              '月折旧率
                Select Case .Fields("DeprMethod")
                    Case "01"
                        Com_DeprMethod.Text = "不计提折旧"
                    Case "02"
                        Com_DeprMethod.Text = "平均年限法(依净资产计提折旧)"
                    Case "03"
                        Com_DeprMethod.Text = "平均年限法(依帐面原值计提折旧)"
                    Case "04"
                        Com_DeprMethod.Text = "工作量法"
                    Case "05"
                        Com_DeprMethod.Text = "固定折旧额折旧法"
                    Case "06"
                        Com_DeprMethod.Text = "年数总和法"
                    Case "07"
                        Com_DeprMethod.Text = "双倍余额法"
                End Select
            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
    
    Dim aDo_Rec As New Recordset
    '非数据行不能删除
    If CzxsGrid.Row < CzxsGrid.FixedRows Then
        Exit Sub
    End If
  
    '已引用类别不能删除
    Set rstemp = Cw_DataEnvi.DataConnect.Execute("select FASortCode='" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) & "' from Gdzc_variation")
    If Not rstemp.EOF Then
        Tsxx = "此类别已被引用,不能删除!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
    rstemp.Close
    Set rstemp = Nothing
  
    '用户确认是否删除记录
    Tsxx = "请确认是否删除当前记录?"
    yhAnswer = Xtxxts(Tsxx, 2, 2)
    If yhAnswer = 2 Then
        Exit Sub
    End If
  
    Set aDo_Rec = Cw_DataEnvi.DataConnect.Execute("select * from Gdzc_Sort where FASortCode='" & Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) & "' and EndFlag='0'")
    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 Gdzc_Sort where FaSortCode = '" + Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))) + "'"
    '=================
    Dim i As Integer, LevelLeng As Integer
    For i = 1 To Len(CodScheme)
        LevelLeng = LevelLeng + Val(Mid(CodScheme, i, 1))
        If Len(Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls)))) = LevelLeng Then
            If i = 1 Then Exit For
            '----------------
            Set aDo_Rec = Cw_DataEnvi.DataConnect.Execute("select * from Gdzc_Sort where FAParentCode='" & Mid(Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))), 1, LevelLeng - Val(Mid(CodScheme, i, 1))) & "'")
            If aDo_Rec.RecordCount = 0 Then
                Cw_DataEnvi.DataConnect.Execute ("update Gdzc_Sort set EndFlag=1 where FaSortCode='" & Mid(Trim(CzxsGrid.TextMatrix(CzxsGrid.Row, Sydz("001", GridStr(), Szzls))), 1, LevelLeng - Val(Mid(CodScheme, i, 1))) & "'")
            End If
            Exit For
        End If
    Next i
    '=================
  
    Add_Tree
    '以上为自定义部分<<]
  
    Cw_DataEnvi.DataConnect.CommitTrans
  
    '将记录加入网格
    Call Cxnrtcwg

    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

'*******************以下区域为编写自定义过程区域**********************
'为零时清空单元格
Function Txt_Clear()
    
    Dim Row_Integer, Col_Integer As Integer         '行数和列数变量
    
    For Row_Integer = CzxsGrid.FixedRows To CzxsGrid.Rows - 1
        For Col_Integer = 5 To 7
            If Val(CzxsGrid.TextMatrix(Row_Integer, Col_Integer)) = 0 Then
                CzxsGrid.TextMatrix(Row_Integer, Col_Integer) = ""
            End If
        Next Col_Integer
    Next Row_Integer
    
End Function

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

'******************以下为基本处理程序(固定不变)************************'
Private Sub Add_Tree() '添加树项
    
    Dim aDo_Sort As New Recordset
    TreeView.Nodes.Clear
    TreeView.Nodes.Add , 4, "T", "资产类别", "T"
    Set aDo_Sort = Cw_DataEnvi.DataConnect.Execute("select a.*,mj=(select count(*) from Gdzc_Sort where Gdzc_Sort.FAParentCode=a.FaSortCode) from Gdzc_Sort a order by a.FaSortCode")
    With aDo_Sort
        Do While Not .EOF
            If Trim("" & aDo_Sort!FAParentCode) = "" Then
                If !mj < 1 Then
                    Set nodX = TreeView.Nodes.Add("T", 4, "T" & Trim(.Fields("FaSortCode")), "(" & Trim(.Fields("FaSortCode")) & ")" & Trim(.Fields("FaSortName")), "C")
                Else
                    Set nodX = TreeView.Nodes.Add("T", 4, "T" & Trim(.Fields("FaSortCode")), "(" & Trim(.Fields("FaSortCode")) & ")" & Trim(.Fields("FaSortName")), "Cl")
                End If
                nodX.EnsureVisible
            Else
                If !mj < 1 Then
                    Set nodX = TreeView.Nodes.Add("T" & Trim(!FAParentCode), 4, "T" & Trim(.Fields("FaSortCode")), "(" & Trim(.Fields("FaSortCode")) & ")" & Trim(.Fields("FaSortName")), "C")
                Else
                    Set nodX = TreeView.Nodes.Add("T" & Trim(!FAParentCode), 4, "T" & Trim(.Fields("FaSortCode")), "(" & Trim(.Fields("FaSortCode")) & ")" & Trim(.Fields("FaSortName")), "Cl")
                End If
            End If
            .MoveNext
        Loop
    End With
    
End Sub
 
'编码方案
Private Sub Text_CodScheme()
    
    Dim aDo_Sort As New Recordset
    Dim i As Integer, h As Integer
    Set aDo_Sort = Cw_DataEnvi.DataConnect.Execute("select * from Gy_CodeScheme where ItemCode='" & Trim(CodSchemeIndex) & "'")
    CodScheme = Trim(aDo_Sort!CodeScheme)
    aDo_Sort.Close
    '-------------
    StTab.Tab = 1
    Lbl_codescheme.Caption = ""
    For i = 1 To Len(CodScheme)
        For h = 1 To Val(Mid(CodScheme, i, 1))
            Lbl_codescheme = Lbl_codescheme & "*"
        Next
        Lbl_codescheme = Lbl_codescheme & " "
    Next i
    Lbl_codescheme = Trim(Lbl_codescheme)

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

Private 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 属性
    TreeView.Top = tbToolBar.Height + picTitles.Height
    StTab.Top = TreeView.Top
    '设置 height 属性
    TreeView.Height = Me.ScaleHeight - (picTitles.Top + picTitles.Height)
    'Frame1.Width = StTab.Width - Frame1.Left * 2
    Dim St_tab As Integer
    St_tab = StTab.Tab
    StTab.Tab = 0
    CzxsGrid.Width = StTab.Width - CzxsGrid.Left * 2
    StTab.Tab = St_tab
    StTab.Height = TreeView.Height
    imgSplitter.Top = TreeView.Top
    imgSplitter.Height = TreeView.Height

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 SzToolbar.Buttons("zj").Visible And SzToolbar.Buttons("zj").Enabled Then
                    Call Toolbjzt
                    Lrzt = 1
                    Call Cshlrxx(Lrzt)
                    LrText(0).SetFocus
                    LrText(0).Locked = False
                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