+

VB开发的ERP系统

    Sqlstr = "select * from PM_taxrate order by taxGrade"
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    
    With RecTemp
        WglrGrid.Rows = WglrGrid.FixedRows
        jsqte = WglrGrid.FixedRows
        
        Do While Not .EOF
            
            WglrGrid.AddItem ""
            WglrGrid.TextMatrix(jsqte, 0) = "*"                                                                             '有效记录标识
            WglrGrid.TextMatrix(jsqte, Sydz("001", GridStr(), Szzls)) = .Fields("TaxGrade")                  '级次
            WglrGrid.TextMatrix(jsqte, Sydz("002", GridStr(), Szzls)) = .Fields("TaxLowLimit")               '级次下限
            If .Fields("TaxUpLimit") <> 0 Then
                WglrGrid.TextMatrix(jsqte, Sydz("003", GridStr(), Szzls)) = .Fields("TaxUpLimit")            '级次上限
            End If
            WglrGrid.TextMatrix(jsqte, Sydz("004", GridStr(), Szzls)) = .Fields("TaxRate")                   '税率
            WglrGrid.TextMatrix(jsqte, Sydz("005", GridStr(), Szzls)) = .Fields("QuickDeduct")               '速算扣除数
           
            '<<]
            
            WglrGrid.RowHeight(jsqte) = Sjhgd
            .MoveNext
            jsqte = jsqte + 1
        Loop
    End With
    
    '将网格刷新解禁(Fixed)
    WglrGrid.Redraw = True
    
       
End Sub



Private Sub LrText_KeyPress(Index As Integer, KeyAscii As Integer)
    Call InputFieldLimit(LrText(Index), 4, KeyAscii)
    If Len(Trim(LrText(Index))) >= 6 And KeyAscii <> 8 Then
        KeyAscii = 0
    End If
End Sub

Private Sub Tlb_Action_ButtonClick(ByVal Button As MSComctlLib.Button)             '用户点击工具条
    
    '屏蔽文本框,下拉组合框有效性判断
    
    Valilock = True
    
    '屏蔽网格失去焦点产生的有效性判断
    
    Changelock = True
    
    Select Case Button.Key
    Case "ymsz"                                          '页面设置
        Dyymctbl.Show 1
    Case "yl"                                            '预 览
        If Fun_Drfrmyxxpd Then
            Call bbyl(True)
        End If
    Case "dy"                                            '打 印
        If Fun_Drfrmyxxpd Then
            Call bbyl(False)
        End If
    Case "zh"                                            '增 行
        Call zjlrfl
    Case "sh"                                            '删 行
        Call Scdqfl
    Case "bc"
        Call Save_Data
    Case "bz"                                            '帮 助
        Call F1bz
    Case "fh"                                            '退 出
        Unload Me
    End Select
    
    '解 锁
    Valilock = False
    Changelock = False
    
End Sub
Private Sub Save_Data()
    Dim jsqte As Long
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
        Exit Sub
    End If
            
    '保存扣税基数、附加费用、税率表
    If Ydtext.Visible Or YdCombo.Visible Then
        Tsxx = "处于录入状态，不能保存"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
    
      
    If Val(Trim(LrText(0))) = 0 Then
        Tsxx = "扣税基数不能为零!"
        Call Xtxxts(Tsxx, 0, 1)
        Exit Sub
    End If
    '判断数据有效性
    With WglrGrid
        For i = .FixedRows To .Rows - 1
            If Trim(.TextMatrix(i, 4)) = "" Then
                Call Xtxxts("税率为空，不能保存!", 0, 1)
                .Select i, Sydz("004", GridStr(), Szzls)
                Exit Sub
            End If
        Next
    End With
    Sql = ""
    With WglrGrid
        For i = .FixedRows To .Rows - 1
           If Trim(.TextMatrix(i, Sydz("003", GridStr(), Szzls))) <> "" Then
               Sql = Sql & " insert Pm_TaxRate values(" & Val(.TextMatrix(i, Sydz("001", GridStr(), Szzls))) & "," & _
                 Val(.TextMatrix(i, Sydz("002", GridStr(), Szzls))) & "," & _
                 Val(.TextMatrix(i, Sydz("003", GridStr(), Szzls))) & "," & _
                 Val(.TextMatrix(i, Sydz("004", GridStr(), Szzls))) & "," & _
                 Val(.TextMatrix(i, Sydz("005", GridStr(), Szzls))) & ")"
           Else
               Sql = Sql & " insert Pm_TaxRate(taxGrade,taxLowLimit,TaxRate,QuickDeduct) values(" & Val(.TextMatrix(i, Sydz("001", GridStr(), Szzls))) & "," & _
                 Val(.TextMatrix(i, Sydz("002", GridStr(), Szzls))) & "," & _
                 Val(.TextMatrix(i, Sydz("004", GridStr(), Szzls))) & "," & _
                 Val(.TextMatrix(i, Sydz("005", GridStr(), Szzls))) & ")"
           End If
        Next
    End With
    On Error GoTo Err1
    Cw_DataEnvi.DataConnect.BeginTrans
    Cw_DataEnvi.DataConnect.Execute "delete pm_TaxRate"
    If Trim(Sql) <> "" Then
        Cw_DataEnvi.DataConnect.Execute Sql
    End If
    
    Sql = " update gy_AccInformation set ItemValue ='" & Val(Trim(LrText(0))) & "' where ltrim(rtrim(ItemCode))='Base'"
    If Trim(LrText(1)) <> "" Then
        Sql = Sql & " update gy_AccInformation set ItemValue ='" & Val(Trim(LrText(1))) & "' where ltrim(rtrim(ItemCode))='Extra'"
    Else
        Sql = Sql & " update gy_AccInformation set ItemValue ='0' where ltrim(rtrim(ItemCode))='Extra'"
    End If
    Cw_DataEnvi.DataConnect.Execute Sql
    Cw_DataEnvi.DataConnect.CommitTrans
    Call Xtxxts("保存成功!", 0, 4)
    Exit Sub
Err1:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Call Xtxxts("保存不成功!", 0, 1)
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 Tlb_Action.Buttons("dy").Enabled Then
                Call bbyl(False)
            End If
        End Select
    End If
    
End Sub

Private Sub Wbkcl()                                                 '文本框录入之前处理(根据实际情况)
    
    Dim xswbrr As String
    
    With WglrGrid
        Zdlrqnr = Trim(.Text)
        xswbrr = Trim(.Text)
        
        If GridBoolean(.Col, 3) Then   '列表框录入
            
            '填充列表框程序
            Call FillCombo(YdCombo, GridStr(.Col, 5), xswbrr, 0)
        Else
            Wbkbhlock = True
            
            '====以下为用户自定义
            Ydtext.Text = xswbrr
            '====以上为用户自定义
            
            Wbkbhlock = False
            Ydtext.SelStart = Len(Ydtext.Text)
        End If
    End With
    
End Sub

Private Function sjzdyxxpd(Dqpdwgh As Long, Dqpdwgl As Long) As Boolean       '录入数据字段有效性判断,同时进行字段录入事后处理
    '函数参数:Dqpdwgh, Dqpdwgl 当前要判断网格单元所处行列值
    
    Dim Str_JudgeText As String                 '临时有效性判断字段内容(Fixed)
    Dim Coljsq As Long                          '临时列计数器(Fixed)
    Dim RecTemp As New ADODB.Recordset          '临时使用动态集(Fixed)
    Dim Sqlstr As String                        '临时使用查询字符串(Fixed)
    
    With WglrGrid
        
        '非录入状态或非数据行则其有效性为合法(Fixed)
        If Yxxpdlock Or .Row < .FixedRows Then
            sjzdyxxpd = True
            Exit Function
        End If
        
        '取得当前要判断字段内容(Fixed)
        Str_JudgeText = Trim(.TextMatrix(Dqpdwgh, Dqpdwgl))
        
        '根据不同字段进行相应的处理(依据其逻辑编号)
        
        Select Case GridStr(Dqpdwgl, 1)
            
            '[>>以下为自定义部分
            
        Case "003"
            For i = Dqlrwgh To .Rows - 1   ' by tjx
                Str_JudgeText = Trim(.TextMatrix(i, Dqpdwgl))
                If Trim(Str_JudgeText) <> "" Then
                    If Val(Trim(Str_JudgeText)) < Val(Trim(.TextMatrix(i, Dqpdwgl - 1))) Then
                       Tsxx = "应纳税所得额上限不能小于同级的应纳税所得额下限!"
                       Dqlrwgh = i
                       GoTo Lrcwcl
                    End If
                     '本级的上限变化，下级的下限跟着变化
                    If i <> .Rows - 1 Then
                        .TextMatrix(i + 1, Sydz("002", GridStr(), Szzls)) = _
                        .TextMatrix(i, Sydz("003", GridStr(), Szzls))
                    End If
                    
                    If Trim(.TextMatrix(i, Dqpdwgl + 1)) <> "" Then
                       Call CalDedu(i)
                    End If
                Else
                    If i < .Rows - 1 Then
                       Tsxx = "有下级数据，上限不能为空!"
                       Dqlrwgh = i
                       GoTo Lrcwcl
                    End If
                End If
            Next
         Case "004"
             If Val(Str_JudgeText) <> 0 Then
                 Call CalDedu(Dqpdwgh)       '计算速算扣除数
             Else
                 Tsxx = "税率不能为零!"
                 GoTo Lrcwcl
             End If
            '<<以上为自定义部分]
        End Select
        
        '字段录入正确后为零字段清空(Fixed)
        Call Qkwlzd(Dqpdwgh, Dqpdwgl)
        
       
        '字段有效性判断通过,将字段有效性判断加锁直至再次改变(Fixed)
        sjzdyxxpd = True
        Yxxpdlock = True
        Exit Function
    End With
    
Lrcwcl:    '录入错误处理(Fixed)
    
    With WglrGrid
        '给出错误提示信息
        Call Xtxxts(Tsxx, 0, 1)
        
        '返回网格错误位置(ChangeLock避免再次引发RowColChange有效性判断),装入录入载体
        Changelock = True
        .Select Dqpdwgh, Dqpdwgl
        Changelock = False
        Call xswbk
        
        '函数返回False
        sjzdyxxpd = False
        Exit Function
    End With
    
End Function
Private Sub CalDedu(Row As Long)
    '计算速算扣除数
    Dim i As Long
    Dim Dedu As Single
    With WglrGrid
        If .Rows = .FixedRows + 1 Then
            Exit Sub
        End If
        If Row = .FixedRows Then
            Dedu = 0
            Row = Row + 1
        Else
            Dedu = .TextMatrix(Row - 1, Sydz("005", GridStr(), Szzls))
        End If
        
        For i = Row To .Rows - 1
            Dedu = Dedu + Val(.TextMatrix(i, Sydz("002", GridStr(), Szzls))) * 0.01 _
                   * (Val(.TextMatrix(i, Sydz("004", GridStr(), Szzls))) _
                   - Val(.TextMatrix(i - 1, Sydz("004", GridStr(), Szzls))))
            .TextMatrix(i, Sydz("005", GridStr(), Szzls)) = Dedu
        Next
        
    End With
End Sub
Private Function Sjhzyxxpd(ByVal Yxxpdh As Long) As Boolean                  '录入数据行有效性判断,同时进行行处理
    
    Dim Lrywlz As Long                     '录入错误列值(Fixed)
    Dim RecTemp As New ADODB.Recordset     '临时使用动态集
    Dim Sqlstr As String                   '临时查询字符串
    
    With WglrGrid
        
        '判断行为空和无效数据行则清除当前行
        If .Rows <= .FixedRows Then Exit Function   ' 如果没有记录，则退出
        If .TextMatrix(Yxxpdh, 0) <> "*" Then
            Sjhzyxxpd = True
            Exit Function
        Else
            If pdhwk(Yxxpdh) And Yxxpdh + 1 <= .Rows - 1 Then
                If .TextMatrix(Yxxpdh + 1, 0) <> "*" Then
                    Changelock = True
                    .RemoveItem Yxxpdh
                    
                    If .Rows < Pmbcsjhs + .FixedRows + Fzxwghs + 1 Then
                        .AddItem ""
                        .RowHeight(.Rows - 1) = Sjhgd
                    End If
                    
                    Changelock = False
                    Sjhzyxxpd = True
                    Exit Function
                End If
            End If
        End If
        
        '行没有发生变化则不进行有效性判断
        If Hyxxpdlock Then
            Sjhzyxxpd = True
            Exit Function
        End If
        
        '以下为自定义部分[
        
        '1.1首先进行单个不能为空或不能为零判断(Fixed)
        For jsqte = Qslz To .Cols - 1
            
            '字段不能为空
            If GridInt(jsqte, 5) = 1 Then
                If Len(Trim(.TextMatrix(Yxxpdh, jsqte))) = 0 Then
                    Tsxx = GridStr(jsqte, 2)
                    Lrywlz = jsqte
                    GoTo Lrcwcl
                    Exit For
                End If
            End If
            
            '字段不能为零
            If GridInt(jsqte, 5) = 2 Then
                If Val(Trim(.TextMatrix(Yxxpdh, jsqte))) = 0 Then
                    Tsxx = GridStr(jsqte, 2)
                    Lrywlz = jsqte
                    GoTo Lrcwcl
                    Exit For
                End If
            End If
            
        Next jsqte
        
        
        '1.2进行其他有效性判断,编写格式同1.1
        
        '2.放置行处理程序(当数据行通过有效性判断)