salary.bas

金算盘软件代码

Attribute VB_Name = "Salary"
'计算工资表
Public Function SalaryCalc(strWhere As String, lngSalaryListID As Long, lngEditViewFieldID As Long, _
                blnIsZero As Boolean, blnIsTax As Boolean, lngZeroID As Long, lngTaxID As Long, _
                dblDeductLevel As Double, ByVal lngDeductPutFieldID As Long, ByRef blnIsRowRefesh As Boolean, _
                Optional ByVal blnByRowCalc As Boolean = False) As Boolean

    '*************************************************************************
    '工资计算
    '必选参数  :工资计算条件(strWhere),工资表ID(lngSalaryListID),当前grid工资计算的修改项目视图ID(lngEditViewFieldID),扣零否(blnIsZero),
               '扣税否(blnIsTax),扣零项目ID(lngZeroID),扣税项目ID(lngTaxID,扣零级别(dblDeductLevel),发放扣零ID(lngDeductPutFieldID
    '可选参数  :(blnByRowCalc)是否按GRID行计算(False 不按GRID行计算,True 按GRID行计算,
               '在按GRID行计算中不考虑特殊公式计算,并且没有项目变动的计算公式不参与计算)
    '计算顺序  :按公式顺序计算
    '计算条件  :strWhere(不按GRID行计算是对整张工资表(lngSalaryListID=工资表ID),
                       '按GRID行计算是对某一个职员(SalaryData.lngEmployeeID=职员ID AND lngSalaryListID=工资表ID)
    'blnIsRowRefesh :是否刷新工资录入(False(对某一个职员进行工资计算,所作刷新只刷新录入GRID当前行),
               'True(对整张工资表进行工资计算,所作刷新是对整个录入GRID的重新刷新))
    '返回状态  :True计算出错不能刷新 ,False 计算后可以刷新
    '扣零,扣税 :计算之前都作未扣零,扣税处理(对本次扣零,代扣税额清零)
    '按GRID行计算为前端计算，否则为服务端计算
    Dim recFormula As rdoResultset
    Dim strSql As String
    Dim strZ As String
    Dim recZ As rdoResultset
    Dim strFildDec As String
    Dim intFildDec As Integer
    Dim strFildTmp As String
    Dim strFildFlag As String
    Dim dblValue As Double
    Dim rec As rdoResultset
    Dim lngFromID As Long
    Dim blnRefresh As Boolean
    Dim strSQLTmp As String
    Dim blnIsAllCalc As Boolean
    Dim strArrChangeItem() As String
    Dim i As Integer
    Dim j As Integer
    Dim recSalary As rdoQuery
    Dim strDateFunTmp1 As String
    Dim strDateFunTmp2 As String
    
'    If Not blnByRowCalc Then
'        'gclsBase.BaseDB.BeginTrans
'        Set recSalary = gclsBase.BaseDB.CreateQuery("", "{?= CALL" & gclsBase.UID & ".SalaryOraCalc(?,?,?,?,?,?,?,?,?,?) }")
'        recSalary.rdoParameters(0).Direction = rdParamReturnValue
'        recSalary.rdoParameters(1).Direction = rdParamInput
'        recSalary.rdoParameters(2).Direction = rdParamInput
'        recSalary.rdoParameters(3).Direction = rdParamInput
'        recSalary.rdoParameters(4).Direction = rdParamInput
'        recSalary.rdoParameters(5).Direction = rdParamInput
'        recSalary.rdoParameters(6).Direction = rdParamInput
'        recSalary.rdoParameters(7).Direction = rdParamInput
'        recSalary.rdoParameters(8).Direction = rdParamInput
'        recSalary.rdoParameters(9).Direction = rdParamInput
'        recSalary.rdoParameters(10).Direction = rdParamInput
'        recSalary.rdoParameters(1).Value = strWhere
'        Debug.Print strWhere
'        Debug.Print lngSalaryListID
'        Debug.Print lngEditViewFieldID
'        Debug.Print blnIsZero
'        Debug.Print blnIsTax
'        Debug.Print lngZeroID
'        Debug.Print lngTaxID
'        Debug.Print dblDeductLevel
'        Debug.Print lngDeductPutFieldID
'        Debug.Print blnByRowCalc
'        recSalary.rdoParameters(2).Value = lngSalaryListID
'        recSalary.rdoParameters(3).Value = lngEditViewFieldID
'        If blnIsZero Then
'            recSalary.rdoParameters(4).Value = 1
'        Else
'            recSalary.rdoParameters(4).Value = 0
'        End If
'        If blnIsTax Then
'            recSalary.rdoParameters(5).Value = 1
'        Else
'            recSalary.rdoParameters(5).Value = 0
'        End If
'        recSalary.rdoParameters(6).Value = lngZeroID
'        recSalary.rdoParameters(7).Value = lngTaxID
'        recSalary.rdoParameters(8).Value = dblDeductLevel
'        recSalary.rdoParameters(9).Value = lngDeductPutFieldID
'        If blnByRowCalc Then
'            recSalary.rdoParameters(10).Value = 1
'        Else
'            recSalary.rdoParameters(10).Value = 0
'        End If
'        recSalary.Execute
'        If recSalary.rdoParameters(0).Value = 0 Then
'            ShowMsg 0, "工资计算时出错！", vbInformation, frmMain.Caption
'            SalaryCalc = False
'            'gclsBase.BaseDB.RollBacktrans
'            Exit Function
'        End If
'        SalaryCalc = True
'        'gclsBase.BaseDB.CommitTrans
'    Else
        
        blnRefresh = False
        SalaryCalc = False
        strSql = "SELECT * FROM SalaryFormula WHERE lngSalaryListID=" & lngSalaryListID _
            & " Order By lngSalaryFormulaId "
        Set recFormula = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recFormula.EOF Then
            recFormula.MoveLast
            recFormula.MoveFirst
            ReDim strArrChangeItem(0)
            strArrChangeItem(0) = ""
        Else
            Exit Function
        End If
        On Error GoTo Errors1
        For i = 0 To recFormula.RowCount - 1  '按公式计算
            '扣税
            If UCase(Trim(recFormula!strSalaryFormula)) = "CALCTAX" Then
                If blnIsTax Then
                    If blnByRowCalc Then
                        '在按GRID行计算中扣税项目是变动项目计算扣税,否则不计算
                        blnIsAllCalc = False
                        If lngTaxID = lngEditViewFieldID Then
                            blnIsAllCalc = True
                        Else
                            For j = 0 To UBound(strArrChangeItem)
                                If Trim(strArrChangeItem(j)) <> "" Then
                                    If UCase(Trim(strArrChangeItem(j))) = "SA" & lngTaxID Then
                                        blnIsAllCalc = True
                                        Exit For
                                    End If
                                End If
                            Next
                        End If
                    Else
                        blnIsAllCalc = True
                    End If
                    If blnIsAllCalc Then
                        If blnByRowCalc Then
                            '清代扣税额
                            strSql = "UPDATE SalaryData SET dblNowTax= 0 WHERE " & strWhere
                            gclsBase.BaseDB.Execute strSql
                            Call CalcRowTax(strWhere, lngTaxID)
                            ReDim Preserve strArrChangeItem(UBound(strArrChangeItem) + 1)
                            strArrChangeItem(UBound(strArrChangeItem)) = "dblNowTax"
                        Else
                            '清代扣税额
                            strSql = "UPDATE SalaryData SET dblNowTax= 0 WHERE " & strWhere
                            gclsBase.BaseDB.Execute strSql
                            Call CalcTax(strWhere, lngTaxID)
                            ReDim Preserve strArrChangeItem(UBound(strArrChangeItem) + 1)
                            strArrChangeItem(UBound(strArrChangeItem)) = "dblNowTax"
                        End If
                    End If
                End If
            End If
            '扣零
            If UCase(Trim(recFormula!strSalaryFormula)) = "CALCZERO" Then
                If blnIsZero Then
                    If blnByRowCalc Then
                        '在按GRID行计算中扣零项目是变动项目计算扣零,否则不计算
                        blnIsAllCalc = False
                        If lngZeroID = lngEditViewFieldID Then
                            blnIsAllCalc = True
                        Else
                            For j = 0 To UBound(strArrChangeItem)
                                If Trim(strArrChangeItem(j)) <> "" Then
                                    If UCase(Trim(strArrChangeItem(j))) = "SA" & lngZeroID Then
                                        blnIsAllCalc = True
                                        Exit For
                                    End If
                                End If
                            Next
                        End If
                    Else
                        blnIsAllCalc = True
                    End If
                    If blnIsAllCalc Then
                        '清本次扣零
                        strSql = "UPDATE SalaryData SET dblNowZero= 0 WHERE " & strWhere
                        gclsBase.BaseDB.Execute strSql
                        Call CalaZero(strWhere, lngZeroID, dblDeductLevel)
                        ReDim Preserve strArrChangeItem(UBound(strArrChangeItem) + 1)
                        strArrChangeItem(UBound(strArrChangeItem)) = "dblNowZero"
                    End If
                End If
            End If
            '发放扣零
            If UCase(Trim(recFormula!strSalaryFormula)) = "PUTZERO" Then
                If blnByRowCalc Then
                    '在按GRID行计算中发放扣零项目是变动项目计算发放扣零,否则不计算
                    blnIsAllCalc = False
                    If lngDeductPutFieldID = lngEditViewFieldID Then
                        blnIsAllCalc = True
                    Else
                        For j = 0 To UBound(strArrChangeItem)
                            If Trim(strArrChangeItem(j)) <> "" Then
                                If UCase(Trim(strArrChangeItem(j))) = "SA" & lngDeductPutFieldID Then
                                    blnIsAllCalc = True
                                    Exit For
                                End If
                            End If
                        Next
                    End If
                Else
                    blnIsAllCalc = True
                End If
                If blnIsAllCalc Then
                    Call PutZero(strWhere, lngDeductPutFieldID)
                    ReDim Preserve strArrChangeItem(UBound(strArrChangeItem) + 1)
                    strArrChangeItem(UBound(strArrChangeItem)) = "SA" & lngDeductPutFieldID
                End If
            End If
            dblValue = 0
            '其他特殊公式计算(按GRID行计算不计算特殊公式)
            If UCase(Trim(recFormula!strSalaryFormula)) <> "CALCZERO" And _
                UCase(Trim(recFormula!strSalaryFormula)) <> "CALCTAX" And _
                UCase(Trim(recFormula!strSalaryFormula)) <> "PUTZERO" And _
                Trim(recFormula!strSalaryFormula) <> "" And _
                recFormula!strFormulaType = "1" And blnByRowCalc = False Then
                strSql = "SELECT " & recFormula!strSalaryFormula & " AS dblValue FROM SalaryData "
                '判断统计函数的表
                Select Case recFormula!lngFunctionSalaryListID
                Case 0   '本次发放的工资表
                    lngFromID = lngSalaryListID
                Case -1  '上次发放的工资表
                    strSQLTmp = "SELECT Max(lngSalaryListID) AS ID FROM SalaryList WHERE lngSalaryListID<" _
                        & lngSalaryListID
                    Set rec = gclsBase.BaseDB.OpenResultset(strSQLTmp, rdOpenStatic)
                    If rec.EOF Then
                        lngFromID = lngSalaryListID
                    Else
                        lngFromID = rec!ID
                    End If
                Case Else
                    lngFromID = recFormula!lngFunctionSalaryListID
                End Select
                strSql = strSql & " WHERE lngSalaryListID=" & lngFromID
                If Trim(recFormula!strFunctionCond) <> "" Then