VB开发的ERP系统

        Call xswbk
        Call Lrzdbz
    Case vbKeyDelete               '删行
        Call Scdqfl
    Case vbKeyInsert               '增行
        Call zjlrfl
    End Select
    
End Sub

Private Sub WglrGrid_KeyPress(KeyAscii As Integer)                             '网格接受键盘录入
    
    '当某种条件成立时禁止文本框激活使单据处于录入状态
    If Not Fun_AllowInput Then
        Exit Sub
    End If
    
    With WglrGrid
        
        '屏 蔽 回 车 键
        If KeyAscii = vbKeyReturn Then
            KeyAscii = 0
            Rowjsq = .Row
            Coljsq = .Col + 1
            If Coljsq > .Cols - 1 Then
                If Rowjsq < .Rows - 1 Then
                    Rowjsq = Rowjsq + 1
                End If
                Coljsq = Qslz
            End If
            Do While Rowjsq <= .Rows - 1
                If .ColHidden(Coljsq) Or (Not GridBoolean(Coljsq, 1)) Then
                    Coljsq = Coljsq + 1
                    If Coljsq > .Cols - 1 Then
                        Rowjsq = Rowjsq + 1
                        Coljsq = Qslz
                    End If
                Else
                    Exit Do
                End If
            Loop
            
            If Rowjsq <= .Rows - 1 Then
                .Select Rowjsq, Coljsq
            End If
            
            Exit Sub
        End If
        
        '接受用户录入
        Select Case KeyAscii
        Case 0 To 32             '用户输入KeyAscii为0-32的键 如空格
            
            '显示录入载体
            Call xswbk
            
        Case Else
            
            '防止非编辑字段SendKeys()出现死循环
            If Not GridBoolean(.Col, 1) Or .Row < .FixedRows Then
                Exit Sub
            End If
            
            '如果此字段为列表框录入则调入相应列表框
            If GridBoolean(.Col, 3) Then
                
                '列表框录入
                Call xswbk
            Else
                
                Ydtext.Text = ""
                
                '录入限制
                Call InputFieldLimit(Ydtext, GridInt(WglrGrid.Col, 1), KeyAscii)
                
                If KeyAscii = 0 Then
                    Exit Sub
                End If
                
                '如果录入字符有效则写有效行数据标志
                Call Xyxhbz(.Row)
                Call xswbk
                Ydtext.Text = ""
                Valilock = True
                SendKeys Chr(KeyAscii), True
                DoEvents
                Valilock = False
            End If
        End Select
    End With
    
End Sub

Private Sub zjlrfl()                                                    '增加录入分录
    
    With WglrGrid
        
        '处于录入状态不能增行
        If Not (Ydtext.Visible Or YdCombo.Visible) Then
            If Not Fun_Drfrmyxxpd Then
                Exit Sub
            End If
        Else
            Exit Sub
        End If
        
        '处于非数据行和最后一行时不能增行
        If .Row < .FixedRows Or .Row = .Rows - 1 Then
            Exit Sub
        End If
        
        .AddItem "", .Row
        .RowHeight(.Row) = Sjhgd
        
        If .Row <> .Rows - 1 Then
            If .TextMatrix(.Row + 1, 0) = "*" Then
                .TextMatrix(.Row, 0) = "*"
            Else
                .RemoveItem .Rows - 1
            End If
        End If
        Call Xldqh
        Call Xldql
        Hyxxpdlock = False
    End With
    
End Sub

Private Sub Scdqfl()                                                    '删除当前分录
    Dim Answer As Integer, Scqwghz As Long, Scqwglz As Long, Hjlzte As Long, Sflrzt As Boolean
    
    '[>>
    Dim Str_BGDays As String               '临时起止天数(标题)
    Dim Int_MaxBillAge As Long             '临时终止天数
    Dim Lng_GridRow As Long                '网格当前行(以便重新刷新网格后定位)
    Dim Int_row As Long
    '<<]
    
    With WglrGrid
        Scqwghz = .Row
        Scqwglz = .Col
        If .TextMatrix(.Row, 0) = "*" Then
            
            '判断是否为录入状态
            If Ydtext.Visible Or YdCombo.Visible Then
                Sflrzt = True
                Validate = True
                Call Lrsjhx
                Validate = False
            End If
            
            Call Xldqh
            Changelock = True
            .Select .Row, 0
            Changelock = False
            If Shsfts Then
                .Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = QBColor(12)
                Tsxx = "请确认是否删除当前记录?"
                Yhanswer = Xtxxts(Tsxx, 2, 2)
                If Yhanswer = 2 Then
                    .Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = &H80000005
                    Changelock = True
                    .Select Scqwghz, Scqwglz
                    Changelock = False
                    
                    '如为录入状态,则恢复录入
                    If Sflrzt Then
                        Call xswbk
                    End If
                    
                    Exit Sub
                End If
            End If
            
            .RemoveItem .Row
            
            On Error GoTo Swcwcl
            
            Int_row = 0
            Cw_DataEnvi.DataConnect.BeginTrans
            
            Cw_DataEnvi.DataConnect.Execute ("Delete Rs_OtherSet Where ItemProperty=1")
            
            For jsqte = WglrGrid.FixedRows To WglrGrid.Rows - 1
                
                Int_row = Int_row + 1
                Str_ItemName = "Age" + Str(Int_row)
                If WglrGrid.TextMatrix(jsqte, 0) = "*" Then
                               
                    Int_MaxBillAge = Val(WglrGrid.TextMatrix(jsqte, Sydz("002", GridStr(), Szzls)))
                    Sqlstr = "Insert Into Rs_OtherSet (ItemName,ItemParameter,ItemProperty) values ('" & Trim(Str_ItemName) & "','" & Int_MaxBillAge & "',1)"
                    Cw_DataEnvi.DataConnect.Execute (Sqlstr)
                
                End If
            Next jsqte
            
            Cw_DataEnvi.DataConnect.CommitTrans
            
            '刷新查询结果
            Lng_GridRow = WglrGrid.Row
            
            Call Sub_Query
            
            Changelock = True
            WglrGrid.Row = Lng_GridRow
            WglrGrid.Col = Scqwglz
            Changelock = False
            
        End If
    End With
    
    Exit Sub
    
    '[>>事务错误处理
Swcwcl:
    Cw_DataEnvi.DataConnect.RollbackTrans
    txss = "删除过程中出现错误!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Sub
    '<<]
End Sub

Private Sub Qkwlzd(sjh As Long, Sjl As Long)                            '清空为零字段
    
    If Not GridBoolean(Sjl, 5) Then
        Exit Sub
    End If
    
    With WglrGrid
        If Val(Trim(.TextMatrix(sjh, Sjl))) = 0 Then
            .TextMatrix(sjh, Sjl) = ""
        End If
    End With
    
End Sub

Private Sub fhyxh()                                                     '返回录入数据有效行,同时让得到焦点网格可见
    
    With WglrGrid
        If .Row >= .FixedRows Then
            If .TextMatrix(.Row, 0) <> "*" Then
                For Rowjsq = .FixedRows To .Rows - 1
                    If .TextMatrix(Rowjsq, 0) <> "*" Then
                        Exit For
                    End If
                Next Rowjsq
                If Rowjsq <= .Rows - 1 Then
                    Changelock = True
                    .Select Rowjsq, .Col
                    Changelock = False
                Else
                    Changelock = True
                    .Select .Rows - 1, .Col
                    Changelock = False
                End If
            End If
            Call Xldqh
        End If
    End With
    
End Sub

Private Sub Xldqh()                                                      '显露当前行
    
    Dim Toprowte As Long
    
    With WglrGrid
        Toprowte = 0
        
        Do While .CellTop + .RowHeight(.Row) + Fzxwghs * Sjhgd > .Height And .TopRow <> Toprowte
            Toprowte = .TopRow
            .TopRow = .TopRow + 1
        Loop
        
        Toprowte = 0
        
        Do While .CellTop < .FixedRows * .RowHeight(0) And .TopRow <> Toprowte
            Toprowte = .TopRow
            .TopRow = .TopRow - 1
        Loop
    End With
    
End Sub

Private Sub Xldql()                                                     '显露当前列
    
    Dim Leftcolte As Long
    
    With WglrGrid
        If .Col >= Qslz And .Col >= .FixedCols Then
            If .LeftCol > .Col Then
                .LeftCol = .Col
            End If
            Leftcolte = 0
            Do While .CellLeft + .CellWidth > .Width And .LeftCol <> Leftcolte
                Leftcolte = .LeftCol
                .LeftCol = .LeftCol + 1
            Loop
        End If
    End With
    
End Sub

Private Function pdhwk(sjh As Long)                                     '判断网格行是否为空行(所有录入字段均为空*非录入字段除外)
    
    With WglrGrid
        For Coljsq = Qslz To .Cols - 1
            If Len(Trim(.TextMatrix(sjh, Coljsq))) <> 0 And GridBoolean(Coljsq, 1) Then
                pdhwk = False
                Exit Function
            End If
        Next Coljsq
        pdhwk = True
    End With
    
End Function

Private Sub Xyxhbz(sjh As Long)                                         '写行有效性标志,并判断是否增行
    
    With WglrGrid
        If .TextMatrix(sjh, 0) = "*" Then
            Exit Sub
        End If
        .TextMatrix(sjh, 0) = "*"
        If sjh >= .Rows - Fzxwghs - 1 Then
            .AddItem ""
            .RowHeight(.Rows - 1) = Sjhgd
        End If
    End With
    
End Sub

Private Sub WglrGrid_BeforeMoveColumn(ByVal Col As Long, Position As Long)           '网格列发生移动时自动交换网格索引信息
    
    Call 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(WglrGrid, GridCode, GridStr())
    Case "hfmrgs"                                     '恢复默认格式
        Call Hfmrgs(WglrGrid, GridCode, GridStr())
    End Select
    
End Sub

Private Sub bbyl(bbylte As Boolean)                    '报表打印预览
    
    Dim Bbzbt$, Bbxbt() As String, bbxbtzzxs() As Integer, Bbxbtgs As Integer
    Dim Bbbwh() As String, Bbbwhzzxs() As Integer, Bbbwhgs As Integer
    Bbxbtgs = 1                                          '报 表 小 标 题 行 数
    Bbbwhgs = 0                                          '报 表 表 尾 行 数
    ReDim Bbxbt(1 To Bbxbtgs)
    ReDim bbxbtzzxs(1 To Bbxbtgs)
    
    If Bbbwhgs <> 0 Then
        ReDim Bbbwh(1 To Bbbwhgs)
        ReDim Bbbwhzzxs(1 To Bbbwhgs)
    End If
    
    Bbzbt = ReportTitle
    
    Call Scyxsjb(WglrGrid)                               '生成报表数据
    Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
    
    If Not bbylte Then
        Unload DY_Tybbyldy
    End If
    
End Sub