showalterinfo.bas

金算盘软件代码

    Dim intCalcPeriod As Integer
    Dim dblCalcAmount As Double
    Dim dblCalcDeprection As Double
    Dim dblInitAmount As Double
    Dim dblInitDeprection As Double
    Dim dblInitAccumaWork As Double
    
    strSql = "SELECT lngFixedCardID FROM FixedCard"
    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do While Not recRecordset.EOF
        '根据卡片ID查找当前会计期间是否有记录
        strSql = "SELECT * FROM FixedBalance WHERE lngFixedCardID=" & recRecordset!lngFixedCardID _
            & " AND intYear*100+bytPeriod<=" & CLng(gclsBase.AccountYear) * 100 + gclsBase.Period _
            & " ORDER BY intYear Desc,bytPeriod Desc"
        Set recBalance = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recBalance.EOF Then
            '增加记录
            If recBalance!intYear <> gclsBase.AccountYear Or recBalance!bytPeriod <> gclsBase.Period Then
            intUseAge = recBalance!intCalcUseAge
            dblCalcAmount = recBalance!dblCalcAmount
            intCalcPeriod = recBalance!intCalcPeriod + recBalance!intPeriod
            intBeelinePeriod = recBalance!intBeelinePeriod
            dblInitAmount = recBalance!dblInitAmount + recBalance!dblDebitAmount + recBalance!dblCreditAmount
            dblInitDeprection = recBalance!dblInitDeprection + recBalance!dblDeprection + recBalance!dblAlterDeprection
            dblInitAccumaWork = recBalance!dblInitAccumaWork + recBalance!dblWork
            dblCalcDeprection = recBalance!dblCalcDeprection + recBalance!dblDeprection + IIf(recBalance.RowCount > 1, recBalance!dblAlterDeprection, 0)
            
            strSql = "INSERT INTO FixedBalance(lngFixedCardID,intYear,bytPeriod,dblInitAmount,dblInitDeprection, " _
                & "dblInitAccumaWork,intCalcUseAge,dblCalcAmount,dblCalcDeprection,intCalcPeriod,intBeelinePeriod) VALUES(" & recRecordset!lngFixedCardID & "," _
                & gclsBase.AccountYear & "," & gclsBase.Period & "," & dblInitAmount & "," & dblInitDeprection & "," _
                & dblInitAccumaWork & "," & intUseAge & "," & dblCalcAmount & "," & dblCalcDeprection & "," & intCalcPeriod & "," & intBeelinePeriod & ")"
            gclsBase.BaseDB.Execute strSql
            End If
        End If
        recBalance.Close
        recRecordset.MoveNext
    Loop
    recRecordset.Close
    Set recRecordset = Nothing
    Set recBalance = Nothing
End Sub


Public Sub RefreshFixedVoucherID(ByVal lngOldID As Long, ByVal lngNewID As Long)
    Dim strSql As String
    
    strSql = "UPDATE FixedAlter SET lngVoucherID=" & lngNewID _
        & " WHERE lngVoucherID=" & lngOldID
    gclsBase.ExecSQL strSql
End Sub
'获取帐套起日期
Public Function GetAccountBeginDate() As String
    Dim strSql As String
    Dim rec As rdoResultset
    strSql = "SELECT strStartDate FROM Business "
    Set rec = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not rec.EOF Then
        GetAccountBeginDate = Format(rec!strStartDate, "yyyy-mm-dd")
    End If
End Function
'四舍五入函数
Public Function FourLostFiveAdd(ByVal dblValue As Double, Optional bytNaturalCurDec As Byte) As Double
    If bytNaturalCurDec = 0 Then
        bytNaturalCurDec = gclsBase.NaturalCurDec
    End If
    FourLostFiveAdd = Int((dblValue + Val("0." & String(bytNaturalCurDec, "0") & "5")) _
        * Val("1" & String(bytNaturalCurDec, "0"))) / Val("1" _
        & String(bytNaturalCurDec, "0"))
End Function
'获取FROM SQL
Public Function GetFrom(ByVal strFromSql As String, ByRef Prameters() As String) As String
    Dim strSql As String
    Dim recSqlView As rdoResultset
    Dim recSql As rdoResultset
    Dim recPrameter As rdoResultset
    Dim i As Long
    Dim strLeft As String
    Dim strRight As String
    Dim strNow As String
    Dim blnDH As Boolean
    blnDH = False
    strSql = "SELECT * FROM ViewSql"
    Set recSql = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    strSql = "SELECT * FROM ViewSqlPrameter"
    Set recPrameter = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    '定位FROM
    i = InStr(UCase(strFromSql), " FROM ")
    If i > 0 Then
        strLeft = Left(strFromSql, i + 6)
        strRight = Right(strFromSql, Len(strFromSql) - i - 5)
    Else
        strLeft = ""
        strRight = strFromSql
    End If
    GetFrom = strLeft
    Do While Len(strRight) <> 0
        i = InStr(strRight, ",")
        If i > 0 Then
            strNow = Left(strRight, i - 1)
            strRight = Right(strRight, Len(strRight) - i)
        Else
            strNow = strRight
            strRight = ""
        End If
        strNow = GetNowSql(strNow, recSql, recPrameter, Prameters())
        If blnDH Then
            GetFrom = GetFrom & " , " & strNow & " "
        Else
            GetFrom = GetFrom & " " & strNow & " "
        End If
        blnDH = True
    Loop
End Function
'替换SQL
Private Function GetNowSql(ByVal strSql As String, ByRef recSql As rdoResultset, ByRef recPrameter As rdoResultset, ByRef Prameters() As String) As String
    Dim strQueref As String
    Dim strName As String
    Dim strNameString As String
    Dim i As Long
    Dim j As Long
    Dim strNowSql As String
    Dim strTmpsql As String
    Dim strFrom As String
    Dim strRight As String
    Dim strWhere As String
    recSql.MoveFirst
    recPrameter.MoveFirst
    Do While Not recSql.EOF
        If UCase(Trim(recSql("strSqlName").Value)) = UCase(Trim(strSql)) Then
            strNowSql = "(SELECT " & recSql("strSELECT1").Value & recSql("strSELECT2").Value _
            & recSql("strSELECT3").Value & recSql("strSELECT4").Value & recSql("strSELECT5").Value _
            & recSql("strSELECT6").Value
            strWhere = recSql("strWHERE1").Value & recSql("strWHERE2").Value & recSql("strWHERE3").Value
            Do While Not recPrameter.EOF
                '替换参数
                If recPrameter("lngViewSqlID").Value = recSql("lngViewSqlID").Value Then
                    i = UBound(Prameters(), 1)
                    For j = 0 To i - 1 Step 1
                        If UCase(Prameters(j, 0)) = UCase(Trim(recPrameter("STRVIEWSQLPRAMETERNAME").Value)) Then
                            strNowSql = Change_Text(Prameters(j, 0), Prameters(j, 1), strNowSql)
                            strWhere = Change_Text(Prameters(j, 0), Prameters(j, 1), strWhere)
                            Exit For
                        End If
                    Next j
                End If
                recPrameter.MoveNext
            Loop
            '替换嵌套查询
            If Trim(recSql("strFROM1").Value) <> "" Then
                strNameString = Trim(recSql("strFrom1").Value)
                strFrom = Trim(recSql("strFrom1").Value)
                strRight = Trim(recSql("strFrom1").Value)
                Do While Len(strRight) <> 0
                    i = InStr(strRight, ",")
                    If i > 0 Then
                        strName = Left(strRight, i - 1)
                        strRight = Right(strRight, Len(strRight) - i)
                    Else
                        strName = strRight
                        strRight = ""
                    End If
                    If blnIsQref(strName) Then
                        strQueref = GetNowSql(strName, recSql, recPrameter, Prameters())
                        strFrom = Change_Text(strName, strQueref, strFrom)
                    End If
                Loop
            End If
            GetNowSql = strNowSql & " FROM " & strFrom & " WHERE " _
                & strWhere & ") " & strSql & " "
            Exit Do
        End If
        recSql.MoveNext
    Loop
End Function
Private Function blnIsQref(ByVal strName As String) As Boolean
    Dim strSql As String
    Dim recSql As rdoResultset
    strSql = "SELECT LNGVIEWSQLID FROM VIEWSQL WHERE UPPER(strsqlname) = '" & UCase(Trim(strName)) & "'"
    Set recSql = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recSql.EOF Then
        blnIsQref = False
    Else
        blnIsQref = True
    End If
End Function

'校验是否已经生成折旧凭证
Public Function CheckOldVoucher() As Boolean
    Dim intYear As Integer
    Dim bytPeriod As Byte
    Dim strSql As String
    Dim recVoucher As rdoResultset
    CheckOldVoucher = False
    bytPeriod = gclsBase.Period
    intYear = Year(gclsBase.BaseDate)
    strSql = "SELECT Voucher.lngCloseID,Voucher.intVoucherNO,VoucherType.strVoucherTypeName" _
        & " FROM Voucher INNER JOIN VoucherType ON VoucherType.lngVoucherTypeID=" _
        & "Voucher.lngVoucherTypeID WHERE Voucher.intYear=" & intYear & " AND " _
        & "Voucher.bytPeriod=" & bytPeriod & " AND lngVoucherSourceID=15 AND Voucher.blnIsVoid=False"
    Set recVoucher = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recVoucher.EOF() Then
        recVoucher.MoveLast
        recVoucher.MoveFirst
        If recVoucher!lngCloseID > 0 Then
            MsgBox "本会计期间的折旧凭证已经生成，且已经记帐，本会计期间不能再提折旧", _
                vbInformation, "计提折旧"
        Else
            MsgBox "本会计期间的折旧凭证已经生成，请先删除" _
                & Trim(recVoucher!strVoucherTypeName) & "第" _
                & recVoucher!intVoucherNO & "号凭证，再提折旧", vbInformation, "计提折旧"
        End If
        CheckOldVoucher = True
    End If
    recVoucher.Close
    Set recVoucher = Nothing
End Function
'写FixedBalance表
Public Sub WriteFixedBalance(ByVal lngFixedCardID As Long)
    Dim strSql As String
    Dim recRecordset As rdoResultset
    Dim bytPeriod As Byte
    Dim recFixedBalance As rdoResultset
    Dim intYear As Integer
    intYear = Year(gclsBase.BaseDate)
    '生成卡片记录集
    If lngFixedCardID = 0 Then
        strSql = "SELECT FixedCard.lngFixedCardID FROM FixedCard , FixedAlter " _
            & "WHERE FixedCard.lngFixedCardID = FixedAlter.lngFixedCardID AND " _
            & "FixedAlter.blnIsVoid = 0"
    Else
        strSql = "SELECT FixedCard.lngFixedCardID FROM FixedCard , FixedAlter " _
            & "WHERE FixedCard.lngFixedCardID = FixedAlter.lngFixedCardID AND " _
            & " FixedAlter.blnIsVoid = 0 AND FixedCard.lngFixedCardID = " & lngFixedCardID
    End If
    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    bytPeriod = gclsBase.Period
    If bytPeriod <= 1 Then
        Exit Sub
    End If
    If recRecordset.EOF Then
        Exit Sub
    Else
        recRecordset.MoveLast
        recRecordset.MoveFirst
    End If
    Do While Not recRecordset.EOF
        lngFixedCardID = recRecordset!lngFixedCardID
        '根据卡片ID查找当前会计期间是否有记录
        strSql = "SELECT lngFixedCardID FROM FixedBalance WHERE lngFixedCardID=" _
            & lngFixedCardID & " AND bytPeriod=" & bytPeriod
        Set recFixedBalance = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If recFixedBalance.EOF Then
            '增加记录
            strSql = "INSERT INTO FixedBalance SELECT Tab1.dblDebitAmount-Tab1.dblCreditAmount+" _
                & "Tab1.dblInitAmount AS dblInitAmount," & bytPeriod & " AS bytPeriod," _
                & intYear & " AS intYear,tab1.dblInitDeprection+Tab1.dblDeprection + " _
                & "Tab1.dblAlterDeprection AS dblInitDeprection,Tab1.lngFixedCardID AS " _
                & "lngFixedCardID FROM FixedBalance as Tab1 WHERE Tab1.bytPeriod=" _
                & bytPeriod - 1 & " AND " _
                & "Tab1.lngFixedCardID=" & lngFixedCardID
            gclsBase.BaseDB.Execute strSql
        End If
        recRecordset.MoveNext
    Loop
End Su