salary.bas

金算盘软件代码

    intCount2 = 0
    intSum = 0
    With objGrid
        For i = 1 To .Rows - 1 Step 1
            If .TextMatrix(i, 1) = 0 Then
                If Trim(.TextMatrix(i, 2)) = "√" Then
                    If Trim(strInWhere) = "" Then
                        strInWhere = "(" & .TextMatrix(i, 0)
                    Else
                        strInWhere = strInWhere & "," & .TextMatrix(i, 0)
                    End If
                    intCount1 = intCount1 + 1
                    If intCount1 = 100 Then
                        If Len(strInWhere) > 0 Then     '增加
                            strSql = "INSERT INTO Salary " _
                                & " (lngEmployeeID,lngDepartmentID,lngEmployeeTypeID,blnIsPersonTax, " _
                                & " lngPersonTaxTypeID,lngBankID,strBankCode,lngSalaryListID) " _
                                & " SELECT lngEmployeeID,lngDepartmentID," _
                                & "lngEmployeeTypeID,blnIsPersonTax,lngPersonTaxTypeID,lngBankID,strBankCode," _
                                & lngSalaryID & " AS lngSalaryListID FROM Employee WHERE " _
                                & "lngEmployeeID IN" & strInWhere & ")"
                            gclsBase.BaseDB.Execute strSql
                            '改变工资扣税标准（一月只有一个扣税标准即个人所得税类别ID）
                            Salary.Update_lngPersonTaxTypeID lngSalaryID
                            strInWhere = ""
                            intCount1 = 0
                        End If
                    End If
                End If
            Else                         '删除
                If Trim(.TextMatrix(i, 1)) = "" Then
                    If Len(strDelSql) = 0 Then
                        strDelSql = "(" & .TextMatrix(i, 0)
                        strName = .TextMatrix(i, 3)
                    Else
                        strDelSql = strDelSql & "," & .TextMatrix(i, 0)
                    End If
                    intCount2 = intCount2 + 1
                    If intCount2 = 100 Then
                        If Trim(strDelSql) > 0 Then   '删除
                            If intSum > 0 Then
                                strDelSql = "DELETE FROM Salary WHERE lngSalaryListID=" & lngSalaryID & _
                                    " AND lngEmployeeID IN" & strDelSql & ")"
                                gclsBase.BaseDB.Execute strDelSql
                                strDelSql = ""
                                intCount2 = 0
                            Else
                                intMsg = ShowMsg(frmMain.hWnd, "取消职员" & strName & "等的工资", vbOKCancel + vbQuestion _
                                    + vbDefaultButton2, "工资发放")
                                If intMsg = vbOK Then
                                    strDelSql = "DELETE FROM Salary WHERE lngSalaryListID=" & lngSalaryID & _
                                        " AND lngEmployeeID IN" & strDelSql & ")"
                                    gclsBase.BaseDB.Execute strDelSql
                                    strDelSql = ""
                                    intCount2 = 0
                                Else
                                    Exit Sub
                                End If
                            End If
                        End If
                        intSum = intSum + 1
                    End If
                End If
            End If
        Next i
    End With
    If Trim(strDelSql) <> "" Then  '删除
        If intSum > 0 Then
            strDelSql = "DELETE FROM Salary WHERE lngSalaryListID=" & lngSalaryID & _
                " AND lngEmployeeID IN" & strDelSql & ")"
            gclsBase.BaseDB.Execute strDelSql
        Else
            intMsg = ShowMsg(frmMain.hWnd, "取消职员" & strName & "等的工资", vbOKCancel + vbQuestion _
                + vbDefaultButton2, "工资发放")
            If intMsg = vbOK Then
                strDelSql = "DELETE FROM Salary WHERE lngSalaryListID=" & lngSalaryID & _
                    " AND lngEmployeeID IN" & strDelSql & ")"
                gclsBase.BaseDB.Execute strDelSql
            Else
                Exit Sub
            End If
        End If
    End If
    If Trim(strInWhere) <> "" Then    '增加
        strSql = "INSERT INTO Salary " _
            & " (lngEmployeeID,lngDepartmentID,lngEmployeeTypeID,blnIsPersonTax, " _
            & " lngPersonTaxTypeID,lngBankID,strBankCode,lngSalaryListID) " _
            & " SELECT lngEmployeeID,lngDepartmentID," _
            & "lngEmployeeTypeID,blnIsPersonTax,lngPersonTaxTypeID,lngBankID,strBankCode," _
            & lngSalaryID & " AS lngSalaryListID FROM Employee WHERE " _
            & "lngEmployeeID IN" & strInWhere & ")"
        gclsBase.BaseDB.Execute strSql
        '改变工资扣税标准（一月只有一个扣税标准即个人所得税类别ID）
        Salary.Update_lngPersonTaxTypeID lngSalaryID
    End If
End Sub
'修改计算公式
Public Sub EditSalaryFormula(objGrid As Object, lngSalaryID As Long)
    Dim i As Integer
    Dim recFomular As rdoResultset
    Dim strSql As String
    
    strSql = "SELECT * FROM SalaryFormula WHERE lngsalaryListID=" & lngSalaryID
    Set recFomular = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurRowVer, 64)
    i = 1
    If Not recFomular.EOF Then
        recFomular.MoveLast
        recFomular.MoveFirst
    End If
    With objGrid
        '写回公式
        On Error GoTo Errors
        gclsBase.BaseWorkSpace.BeginTrans
        Do While i < .Rows And Trim(.TextMatrix(1, 0)) <> ""
            If recFomular.EOF Then
                recFomular.AddNew
                recFomular!lngSalaryListID = lngSalaryID
                recFomular!lngSalaryFormulaID = BillPublic.GetNewID("SalaryFormula")
            Else
                recFomular.Edit
            End If
            recFomular!strSalaryFormulaDesc = IIf(IsNull(.TextMatrix(i, 1)), " ", IIf(Trim(.TextMatrix(i, 1)) = "", " ", Trim(.TextMatrix(i, 1))))
            recFomular!strSalaryCondDesc = IIf(IsNull(.TextMatrix(i, 2)), " ", IIf(Trim(.TextMatrix(i, 2)) = "", " ", Trim(.TextMatrix(i, 2))))
            recFomular!lngViewFieldID = IIf(IsNull(.TextMatrix(i, 3)), 0, Val(.TextMatrix(i, 3)))
            recFomular!strSalaryFormula = IIf(IsNull(.TextMatrix(i, 4)), " ", IIf(Trim(.TextMatrix(i, 4)) = "", " ", Trim(.TextMatrix(i, 4))))
            recFomular!strSalaryCond = IIf(IsNull(.TextMatrix(i, 5)), " ", IIf(Trim(.TextMatrix(i, 5)) = "", " ", Trim(.TextMatrix(i, 5))))
            recFomular!strFunctionCond = IIf(IsNull(.TextMatrix(i, 7)), " ", IIf(Trim(.TextMatrix(i, 7)) = "", " ", Trim(.TextMatrix(i, 7))))
            recFomular!lngFunctionSalaryListID = IIf(IsNull(.TextMatrix(i, 8)), 0, Val(.TextMatrix(i, 8)))
            recFomular!strFormulaType = IIf(IsNull(.TextMatrix(i, 9)), 0, Val(.TextMatrix(i, 9)))
            recFomular.Update
            If Not recFomular.EOF() Then
                recFomular.MoveNext
            End If
            i = i + 1
        Loop
        strSql = "(0"
        Do While Not recFomular.EOF
            strSql = strSql & "," & recFomular!lngSalaryFormulaID
            recFomular.MoveNext
        Loop
        'strSQL = "DELETE SalaryFormula.* FROM SalaryFormula WHERE lngSalaryFormulaID IN" & strSQL & ")"
        strSql = "DELETE FROM SalaryFormula WHERE lngSalaryFormulaID IN" & strSql & ")"
        gclsBase.BaseDB.Execute strSql
        gclsBase.BaseWorkSpace.CommitTrans
    End With
    Exit Sub
Errors:
    MsgBox "公式表被其他用户打开，现在不允许修改", vbInformation, "工资发放"
End Sub

'调用工资条报表
Public Function ShowSalaryBill(ByVal lngReportID As Long, _
    ByVal lngViewId As Long, Optional ByVal lngSalaryListID As Long = 0)
    Dim frmbill As New frmSalaryBill
    Dim strSql As String
    Dim recSalaryList As rdoResultset
    strSql = "SELECT SalaryList.lngSalaryListID, SalaryList.strSalaryListName FROM SalaryList " & _
             " ORDER BY  SalaryList.strDate DESC"
    Set recSalaryList = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recSalaryList.EOF Then
        frmbill.InitSalaryBill lngReportID, lngViewId, lngSalaryListID
    Else
        ShowMsg frmMain.hWnd, "没有工资数据不能查看工资条。", vbInformation, frmMain.Caption
    End If
    recSalaryList.Close
    Set recSalaryList = Nothing
    Set frmbill = Nothing
End Function
'计算扣税
Private Sub CalcTax(ByVal strWhere As String, ByVal lngTaxID As Long)
    Dim qrfSalaryTax As rdoQuery
    Dim recSalary As rdoQuery
    Dim strSql As String
    Dim strErrorqrf As String  '创建错误的Qrf的名称
    Dim dblTaxAmount As Double
    Dim dblTaxRate As Double
    Dim recTmp As rdoResultset
    Dim i As Integer
    
   ' On Error GoTo Errors
    'gclsBase.BaseWorkSpace.BeginTrans
    'strSql = "SELECT SalaryData.lngEmployeeID,IIF(SalaryData.dblLastTax+SalaryData.Sa" _
        & lngTaxID & ">SalaryData.dblDeductAmount,False,True) AS blnNowNew," _
        & "IIF(SalaryData.dblLastTax>SalaryData.dblDeductAmount,False,True) AS blnLastNew,SalaryData.dblStartTaxRate " _
        & "FROM SalaryData WHERE blnIsPersonTax=True AND " & strWhere
    'strErrorqrf = "CalcIsNew"
    'Set qrfSalaryTax = gclsBase.BaseDB.CreateQuery("CalcIsNew", strSql)
    'If strErrorqrf = "" Then
        'Set qrfSalaryTax = gclsBase.BaseDB.CreateQuery("CalcIsNew", strSql)
    'End If
    strSql = " CREATE OR REPLACE VIEW " & gclsBase.UID & ".CalcIsNew AS " _
        & "SELECT SalaryData.lngEmployeeID,DECODE(SIGN(SalaryData.dblLastTax+SalaryData.Sa" _
        & lngTaxID & "-SalaryData.dblDeductAmount),1,0,1) AS blnNowNew," _
        & "DECODE(SIGN(SalaryData.dblLastTax-SalaryData.dblDeductAmount),1,0,1) AS blnLastNew,SalaryData.dblStartTaxRate " _
        & "FROM SalaryData WHERE blnIsPersonTax=1 AND " & strWhere
    gclsBase.BaseDB.Execute strSql
    
    '扣除起征金额后的上次应纳税所得额和扣税项目金额
    '当起征金额小于（上次应纳税所得额+扣税项目金额）时本次用于计算的金额为两者之差
    '否则本次用于计算的金额为零。SalaryTax1,本次金额；SalaryTax2，上次金额
    'strSql = "SELECT SalaryData.lngEmployeeID,IIF(CalcIsNew.blnNowNew,IIF(SalaryData.dblLastTax+" _
        & "SalaryData.Sa" & lngTaxID & ">0,SalaryData.dblLastTax+" _
        & "SalaryData.Sa" & lngTaxID & ",0),IIF(SalaryData.dblLastTax+SalaryData.Sa" _
        & lngTaxID & ">SalaryData.dblStartAmount,SalaryData.dblLastTax+SalaryData.Sa" _
        & lngTaxID & "-SalaryData.dblStartAmount,0)) AS SalaryTax1," _
        & "IIF(CalcIsNew.blnLastNew,IIF(SalaryData.dblLastTax>0,SalaryData.dblLastTax,0),IIF(SalaryData.dblLastTax>" _
        & "SalaryData.dblStartAmount,SalaryData.dblLastTax" _
        & "-SalaryData.dblStartAmount,0)) AS SalaryTax2 FROM SalaryData INNER JOIN " _
        & "CalcIsNew ON CalcIsNew.lngEmployeeID=SalaryData.lngEmployeeID WHERE " _
        & "blnIsPersonTax=True AND " & strWhere
    'strErrorqrf = "CalcSalary1"
    'Set qrfSalaryTax = gclsBase.BaseDB.CreateQuery("CalcSalary1", strSql)
    'If strErrorqrf = "" Then
        'Set qrfSalaryTax = gclsBase.BaseDB.CreateQuery("CalcSalary1", strSql)
    'End If
    strSql = "CREATE OR REPLACE VIEW " & gclsBase.UID & ".CalcSalary1 AS " _
        & "SELECT SalaryData.lngEmployeeID,DECODE(CalcIsNew.blnNowNew,1,DECODE(SIGN(SalaryData.dblLastTax+" _
        & "SalaryData.Sa" & lngTaxID & ") ,1,SalaryData.dblLastTax+" _
        & "SalaryData.Sa" & lngTaxID & ",0),DECODE(SIGN(SalaryData.dblLastTax+SalaryData.Sa" _
        & lngTaxID & "-SalaryData.dblStartAmount),1,SalaryData.dblLastTax+SalaryData.Sa" _
        & lngTaxID & "-SalaryData.dblStartAmount,0)) AS SalaryTax1," _
        & "DECODE(CalcIsNew.blnLastNew,1,DECODE(SIGN(SalaryData.dblLastTax) ,1,SalaryData.dblLastTax,0)," _
        & "DECODE(SIGN(SalaryData.dblLastTax-SalaryData.dblStartAmount),1,SalaryData.dblLastTax" _
        & "-SalaryData.dblStartAmount,0)) AS SalaryTax2 FROM SalaryData,CalcIsNew " _
        & "WHERE CalcIsNew.lngEmployeeID=SalaryData.lngEmployeeID AND " _
        & "blnIsPersonTax=1 AND " & strWhere
    gclsBase.BaseDB.Execute strSql
    '本次应纳税所得额的税率,速算扣除查询
    'strSql = "SELECT CalcSalary1.lngEmployeeID,IIF(CalcIsNew.blnNowNew,CalcIsNew.dblStartTaxRate" _
        & ",PersonTax.dblTaxRate) AS dblTaxRate,IIF(CalcIsNew.blnNowNew,0,PersonTax.dblDiscountTax)" _
        & " AS dblDiscountTax FROM (CalcSalary1 INNER JOIN CalcIsNew ON CalcIsNew.lngEmployeeID=" _
        & "CalcSalary1.lngEmployeeID) LEFT JOIN PersonTax ON PersonTax.dblAmount1<=" _
        & "CalcSalary1.SalaryTax1 AND IIF(PersonTax.dblAmount2=0,True," _
        & "CalcSalary1.SalaryTax1<PersonTax.dblAmount2)"
    'strErrorqrf = "CalcSalary2"
    'Set qrfSalaryTax = gclsBase.BaseDB.CreateQuery("CalcSalary2", strSql)
    'If strErrorqrf = "" Then