fixeddeccalc.bas

金算盘软件代码

Attribute VB_Name = "FixedDecCalc"
Option Explicit
Private intYearPeriod As Integer             '每年的会计期间数
'计算折旧
Private Function CalcDecValue(ByVal strDepreciationMethod As String, ByVal dblInitAmount _
    As Double, ByVal dblNetWorth As Double, ByVal intUseAge As Integer, ByVal dblInitDeprection _
    As Double, Optional intPeriod As Integer, Optional intNowPeriod As _
    Integer, Optional intBeelinePeriod As Integer) As Double
    '折旧方法,期初原值,预计净残值,预计使用年限,累计折旧,已提折旧期间,本次折旧期间数
    Dim intYear As Integer
    CalcDecValue = 0
    '若已提折旧期间大于或等于预计使用年限时不计算折旧
    If intUseAge * intYearPeriod <= intPeriod Then Exit Function
    '若当前净值小于或等于零则不计算折旧
    If dblInitAmount - dblNetWorth - dblInitDeprection <= 0 Then Exit Function
    '已经使用年限
    intYear = intPeriod \ intYearPeriod + 1
    '双倍余额递减法在最后两年按照直线法计算折旧
    If intYear + 1 = intUseAge And strDepreciationMethod = "4" Then
        CalcDecValue = (dblInitAmount - dblInitDeprection - dblNetWorth) _
            / (intBeelinePeriod - intPeriod) * intNowPeriod
        Exit Function
    End If
    Select Case strDepreciationMethod
    '不提折旧
    Case "1"
        CalcDecValue = 0
    '直线法按会计期间计算折旧
    Case "2"
        If intBeelinePeriod = 0 Then
            CalcDecValue = 0
        Else
            CalcDecValue = (dblInitAmount - dblNetWorth) / intBeelinePeriod * intNowPeriod
        End If
    '双倍余额法
    Case "4"
        CalcDecValue = 2 * (dblInitAmount - dblInitDeprection) / intUseAge / intYearPeriod * intNowPeriod
    '年数总和法
    Case "5"
        CalcDecValue = 2 * (dblInitAmount - dblNetWorth) * (intUseAge - intYear + 1) / _
            (intUseAge * (intUseAge + 1)) / intYearPeriod * intNowPeriod
    End Select
End Function
'计算工作量
Private Function CalcWork(ByVal FromYear As Integer, ByVal FromPeriod As Byte, ByVal lngFixedCardID As Long) As Double
    Dim strSql As String
    Dim rec As rdoResultset
    strSql = "SELECT FixedBalance.dblWork AS dblCount FROM FixedBalance WHERE " _
        & "FixedBalance.lngFixedCardID=" & lngFixedCardID & " AND " _
        & "CLng(FixedBalance.intYear)*100+FixedBalance.bytPeriod=" & (CLng(FromYear) * 100 + FromPeriod)
    Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If rec.EOF Then
        CalcWork = 0
    Else
        CalcWork = IIf(IsNull(rec!dblCount), 0, rec!dblCount)
    End If
End Function
'写本期计提折旧
Private Sub WriteBlance(ByVal lngFixedCardID As Long, ByVal intYear As Integer, _
    ByVal bytPeriod As Byte, ByVal dblDecValue As Double, ByVal intTotalPeriod As Integer, ByVal dblCalcDeprection As Double)
    '判断余额表是否为空
    Dim strSql As String
    Dim rec As rdoResultset
    Dim dblInitAmount As Double           '期初原值
    Dim dblInitDeprection As Double       '期初折旧
    Dim dblInitAccumaWork As Double       '期初累计工作量
    Dim dblAmount As Double               '用于计算的原值
    Dim intUseYear As Integer             '用于计算的预计使用年限
    Dim intCalcPeriod As Integer          '用于计算的已提折旧期间
    Dim blnAlter As Boolean               '是否有变动记录
    Dim intUseAge As Integer
    blnAlter = HaveAlterRecord(intYear, bytPeriod, lngFixedCardID)
    '判断当前会计期间是否有余额表记录
    strSql = "SELECT FixedBalance.dblDeprection FROM FixedBalance WHERE " _
        & "FixedBalance.intYear=" & intYear & " AND  FixedBalance.bytPeriod=" _
        & bytPeriod & " AND FixedBalance.lngFixedCardID=" & lngFixedCardID
    Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not rec.EOF Then
        strSql = "SELECT TOP 1 * FROM FixedBalance WHERE (lngFixedCardID)=" & _
            lngFixedCardID & " AND Clng(intYear)*100+bytPeriod<" & (CLng(intYear) * 100 + _
            bytPeriod) & " ORDER BY intYear Desc,bytPeriod Desc"
        Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If rec.EOF Then
            '修改
            strSql = "UPDATE FixedBalance SET dblDeprection=" & dblDecValue & ",intPeriod=" _
                & IIf(dblDecValue <> 0, intTotalPeriod, 0) & " WHERE lngFixedCardID=" & lngFixedCardID & " AND intYear=" _
                & gclsBase.AccountYear & " AND bytPeriod=" & gclsBase.Period
            gclsBase.BaseDB.Execute strSql
        Else
            With rec
                .MoveLast
                dblInitAmount = !dblInitAmount + !dblDebitAmount - !dblCreditAmount
                dblInitDeprection = !dblInitDeprection + !dblDeprection + !dblAlterDeprection
                dblInitAccumaWork = !dblInitAccumaWork + !dblWork
                intUseAge = !intCalcUseAge
                dblAmount = !dblCalcAmount
                intCalcPeriod = !intCalcPeriod + !intPeriod
            End With
            '当前会计期间没有变动记录
            If Not blnAlter Then
                strSql = "UPDATE FixedBalance SET dblDeprection=" & dblDecValue & ",intPeriod=" _
                    & IIf(dblDecValue <> 0, intTotalPeriod, 0) & ",dblInitAmount=" & dblInitAmount & ",dblInitDeprection=" _
                    & dblInitDeprection & ",dblInitAccumaWork=" & dblInitAccumaWork & ",intCalcUseAge=" _
                    & intUseAge & ",dblCalcAmount=" & dblAmount & "+ dblDebitAmount - dblCreditAmount,intCalcPeriod=" & intCalcPeriod _
                    & ",dblCalcDeprection=" & dblCalcDeprection & " WHERE lngFixedCardID=" & lngFixedCardID & " AND intYear=" _
                    & gclsBase.AccountYear & " AND bytPeriod=" & gclsBase.Period
            Else   '只替换折旧和本次计算的会计期间数
                strSql = "UPDATE FixedBalance SET dblDeprection=" & dblDecValue & ",intPeriod=" _
                    & IIf(dblDecValue <> 0, intTotalPeriod, 0) & " WHERE lngFixedCardID=" & lngFixedCardID & " AND intYear=" _
                    & gclsBase.AccountYear & " AND bytPeriod=" & gclsBase.Period
            End If
            gclsBase.BaseDB.Execute strSql
        End If
    Else
        '查找最近会计期间的变动记录
        strSql = "SELECT TOP 1 * FROM FixedBalance WHERE lngFixedCardID=" & _
            lngFixedCardID & " AND Clng(intYear)*100+bytPeriod<" & (CLng(intYear) * 100 + _
            bytPeriod) & " ORDER BY intYear Desc,bytPeriod Desc"
        Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not rec.EOF Then
            With rec
                dblInitAmount = !dblInitAmount + !dblDebitAmount - !dblCreditAmount
                dblInitDeprection = !dblInitDeprection + !dblDeprection + !dblAlterDeprection
                dblInitAccumaWork = !dblInitAccumaWork + !dblWork
                intUseAge = !intCalcUseAge
                dblAmount = !dblCalcAmount
                intCalcPeriod = !intCalcPeriod + !intPeriod
                '插入
                strSql = "INSERT INTO FixedBalance(intYear,bytPeriod,lngFixedCardID,dblInitAmount," _
                    & "dblDebitAmount,dblCreditAmount,dblInitDeprection,dblDeprection," _
                    & "dblAlterDeprection,dblInitAccumaWork,dblWork,intCalcPeriod,intCalcUseAge," _
                    & "dblCalcAmount,dblCalcDeprection,intPeriod) Values( " & intYear & "," & bytPeriod _
                    & "," & lngFixedCardID & "," & dblInitAmount & ",0,0," & dblInitDeprection & "," _
                    & dblDecValue & ",0," & dblInitAccumaWork & ",0," & intCalcPeriod _
                    & "," & intUseAge & "," & dblAmount & "," & dblCalcDeprection & "," & IIf(dblDecValue <> 0, intTotalPeriod, 0) & ")"
                gclsBase.BaseDB.Execute strSql
            End With
        End If
    End If
End Sub
'计算总的折旧
Public Function DecAmount(ByVal intDecPeriod As Integer, ByVal strDepreciationMethod As String, _
    ByVal dblAmount As Double, ByVal dblNetWorth As Double, ByVal intUseAge As Integer, _
    ByVal dblInitDeprection As Double, ByRef blnDec As Boolean, Optional lngFixedCardID As Long, _
    Optional intBeelinePeriod As Integer) As Double
    '累计折旧期间数，折旧方法，期初原值，预计净残值，预计使用年限
    '，累计折旧，是否从新计算累计折旧标志，卡片ID,直线法计算折旧的总会计期间
    Dim strSql As String              '
    Dim rec As rdoResultset              '
    Dim dblCalcDecValue As Double        '折旧值
    Dim i As Integer
    Dim intNowDecPeriod As Integer
    Dim dblDecValue As Double
    Dim dblValue1  As Double
    Dim dblValue2  As Double
    '计算本次折旧期间
    intNowDecPeriod = 1
    '判断开始是的折旧方法是否为双倍余额递减法,且为按照变动前因数计算折旧
    If blnDec Then
        strSql = "SELECT FixedAlter.strDepreciationMethod,FixedAlter.strDeprectionFactor" _
            & " FROM FixedAlter INNER JOIN FixedCard ON (FixedCard.lngCreateFixedAlterID = " _
            & "FixedAlter.lngFixedAlterID) AND (FixedAlter.lngFixedCardID=FixedCard.lngFixedCardID);"
        Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not (rec!strDepreciationMethod = "4" And rec!strDeprectionFactor = "1") _
            Then blnDec = False
        '本次计算折旧为非双倍余额法
        If strDepreciationMethod <> "4" Then blnDec = False
    End If
    '双倍余额法
    Select Case strDepreciationMethod
    Case "2"    '直线法
        DecAmount = CalcDecValue(strDepreciationMethod, dblAmount, dblNetWorth, intUseAge, _
            dblInitDeprection, intDecPeriod, intNowDecPeriod, intBeelinePeriod)
    Case "4"    '双倍余额法
        If (intUseAge - 2) * intYearPeriod - intDecPeriod <= 0 Then
            
'            dblValue1 = CalcDecValue("2", dblAmount - dblInitDeprection, dblNetWorth, _
'                intUseAge, 0, intDecPeriod, intNowDecPeriod, intUseAge * intYearPeriod - intDecPeriod)
            dblValue1 = 0
            If intUseAge * intYearPeriod - intDecPeriod > 0 Then
                For i = 0 To intUseAge * intYearPeriod - intDecPeriod - 1
                    dblValue2 = CalcDecValue("2", dblAmount - dblInitDeprection - dblValue1, dblNetWorth, _
                        intUseAge, 0, intDecPeriod + i, intNowDecPeriod, intUseAge * intYearPeriod - intDecPeriod - i)
                    dblValue1 = dblValue1 + Int(dblValue2 * 100) / 100
                Next i
            End If
            If (intUseAge * intYearPeriod - intDecPeriod) > 0 Then
                dblValue1 = dblValue1 / (intUseAge * intYearPeriod - intDecPeriod)
            End If
            DecAmount = Int(dblValue1 * 100) / 100
            Exit Function
        End If
'        If blnDec Then
            intDecPeriod = (intDecPeriod \ intYearPeriod) * intYearPeriod
            dblDecValue = 0
            If intDecPeriod \ intYearPeriod > 0 Then
                For i = 1 To intDecPeriod \ intYearPeriod
                    dblDecValue = dblDecValue + CalcDecValue(strDepreciationMethod, dblAmount, _
                        dblNetWorth, intUseAge, dblDecValue, i * intYearPeriod, intYearPeriod, intBeelinePeriod)
                Next i
            End If
            DecAmount = CalcDecValue(strDepreciationMethod, dblAmount, _