企业管理

开发平台：
Visual Basic

clsBal.cls：源码内容
							VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsBal"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'*********************************************************************
'*    模 块 名 称 :财务分析资产负债表计算分析类模块
'*    功 能 描 述 :
'*    程序员姓名  :白石军
'*    最后修改人  :
'*    最后修改时间:2002/1/21
'*    备        注:程序中所有依实际情况自定义部分均用[>>  <<]括起
'*
'*********************************************************************
Option Explicit
Private Const SQL = "SELECT * FROM cwfx_BalanceInitial"
Private bSomeThingWrong As Boolean '有错误
Private Conn As New ADODB.Connection '数据连接
Private Rs As New ADODB.Recordset '记录集
Private CodeRs As New ADODB.Recordset '科目记录集
Private sItem As String '项目
Private iMonth As Integer '月
Private iYear As Integer '年
Private bPingJun As Boolean '取平均值
Public Sub Init(ByVal PastConn As ADODB.Connection)
    If DEBUG_FLAG = False Then On Error Resume Next
    Set Conn = PastConn
    With Rs
        If .State = adStateOpen Then .Close
        .ActiveConnection = Conn
        .Source = SQL
        .Open , , adOpenKeyset, adLockBatchOptimistic
        Set .ActiveConnection = Nothing
    End With
    
    With CodeRs
        If .State = adStateOpen Then .Close
        .ActiveConnection = Conn
        .Source = "SELECT * FROM Cwzz_AccCode"
        .Open , , adOpenKeyset, adLockBatchOptimistic
        Set .ActiveConnection = Nothing
    End With
End Sub
Public Function GetFristValue(ByVal strItem As String, ByVal intYear As Integer) As Double
    '取年初值
    If DEBUG_FLAG = False Then On Error Resume Next
    GetFristValue = GetValue(strItem, 0, iYear)
End Function
Public Function GetPeriodValue(ByVal strItem As String, ByVal intPeriod As Integer, ByVal intYear As Integer) As Double
    '取期间值
    If DEBUG_FLAG = False Then On Error Resume Next
    GetPeriodValue = GetValue(strItem, intPeriod, intYear)
End Function
Public Function GetAveragePeriodValue(ByVal strItem As String, ByVal intPeriodBegin As Integer, ByVal intPeriodEnd As Integer, ByVal intYear As Integer) As Double
    '取期平均值
    If DEBUG_FLAG = False Then On Error Resume Next
    Dim dbl_FirstValue As Double
    Dim dbl_EndValue As Double
    bPingJun = True
    dbl_FirstValue = GetValue(strItem, intPeriodBegin, iYear)
    bPingJun = False
    dbl_EndValue = GetValue(strItem, intPeriodEnd, iYear)
    GetAveragePeriodValue = (dbl_FirstValue + dbl_EndValue) / 2
End Function
Private Function GetValue(ByVal strItem As String, ByVal intPeriod As Integer, ByVal intYear As Integer) As Double
    If DEBUG_FLAG = False Then On Error Resume Next
    iMonth = intPeriod
    iYear = intYear
    GetValue = GetVal(strItem)
End Function
'=====================普通取值开始============================
Private Function GetVal(ByVal strItem As String) As Double
    '取出某项目的值（项目值由设定的公式决定）
    '参数：
    'strItem：项目，表中的标识
    If DEBUG_FLAG = False Then On Error Resume Next
    Dim dbl_ReturnVal As Double '返回值
    
    Dim iLen As Integer
    Dim iWordBegin As Integer
    Dim iWordEnd As Integer
    Dim strTem As String
    Dim strSubExp As String
    Dim i As Integer
    Dim opTem As String '加减号
    Dim dbl_RetVal As Double '加数或减数
    With Rs
        If Not (.EOF And .BOF) Then '表不能为空记录集
            .MoveFirst
            .Find "Item='" & strItem & "'"
            If Not .EOF Then '如果找到
                strSubExp = Trim(!account) & "" '取得公式
                If !AccntOrItem = 0 Then '如果为固定公式则拆分此公式，
                    '对每个拆分的项目再次调用此过程
                    '------------------------------------------------------
                    
                    iLen = Len(strSubExp)
                    iWordBegin = 1
                    iWordEnd = 1
                    For i = 1 To iLen
                        
                        strTem = Mid(strSubExp, i, 1)
                        If strTem = "+" Or strTem = "-" Or i = iLen Then
                            If iWordBegin = 1 Then
                                opTem = "+"
                            Else
                                opTem = Mid(strSubExp, iWordBegin - 1, 1)
                            End If
                            
                            strTem = Mid(strSubExp, iWordBegin, i - iWordBegin + 1)
                            strTem = IIf(Right(strTem, 1) = "+" Or Right(strTem, 1) = "-", Left(strTem, Len(strTem) - 1), strTem)
                            '--------------
                            dbl_RetVal = GetVal(strTem)  'ReCall
                            If opTem = "+" Then
                                dbl_ReturnVal = dbl_ReturnVal + dbl_RetVal  'ReCall
                            ElseIf opTem = "-" Then
                                dbl_ReturnVal = dbl_ReturnVal - dbl_RetVal 'ReCall
                            End If
                            
                            '--------------
                            iWordBegin = i + 1
                        End If
                    Next
                    
                    '------------------------------------------------------
                Else '调用取得公式值的过程
                    dbl_ReturnVal = dbl_ReturnVal + GetSubVal(strSubExp)
                End If
            End If
        End If
    End With
    GetVal = dbl_ReturnVal
End Function
Private Function GetSubVal(ByVal strExp As String) As Double
    '取得最终公式值，由GetVal调用
    If DEBUG_FLAG = False Then On Error Resume Next
    Dim dbl_Return As Double '返回值
    Dim iLen As Integer
    Dim iWordBegin As Integer
    Dim iWordEnd  As Integer
    Dim strTem As String
    Dim strSubExp As String
    Dim strSql As String
    Dim i As Integer
    Dim SumRs As New ADODB.Recordset
    strSubExp = Trim(strExp) '取得公式
    
    iLen = Len(strSubExp)
    iWordBegin = 1
    iWordEnd = 1
    For i = 1 To iLen
        
        strTem = Mid(strSubExp, i, 1)
        If strTem = "+" Or strTem = "-" Or i = iLen Then
            strTem = Mid(strSubExp, iWordBegin, i - iWordBegin + 1)
            strTem = IIf(Right(strTem, 1) = "+" Or Right(strTem, 1) = "-", Left(strTem, Len(strTem) - 1), strTem)
            '----------------------------------------------
            
            
            
            If SumRs.State = adStateOpen Then SumRs.Close
            
            
            strSql = "SELECT Qmye AS Qm ,Qcye AS Qc ,Ycye As Yc FROM Cwzz_AccSum Where cCode='" & strTem & "'"
            strSql = strSql & " AND Year=" & iYear
            strSql = strSql & " AND Period=" & IIf(iMonth = 0, 1, iMonth)
            
            
            Set SumRs = Cw_DataEnvi.DataConnect.Execute(strSql)
            
            If Not (SumRs.EOF And SumRs.BOF) Then
                If iWordBegin > 1 Then
                    
                    If Mid(strSubExp, iWordBegin - 1, 1) = "+" Then
                        If Rs!LeftOrRight = 0 Then '负债类科目特殊处理
                            If iMonth = 0 Then '年初
                                dbl_Return = dbl_Return + ifAbs(SumRs!Yc, strTem)
                            Else
                                dbl_Return = dbl_Return + IIf(bPingJun = True, ifAbs(SumRs!Qc, strTem), ifAbs(SumRs!Qm, strTem))
                            End If
                        Else 'ifAbs
                            If iMonth = 0 Then
                                dbl_Return = dbl_Return + ifAbs(SumRs!Yc, strTem)
                            Else
                                dbl_Return = dbl_Return + IIf(bPingJun = True, SumRs!Qc, SumRs!Qm)
                            End If
                        End If
                    ElseIf Mid(strSubExp, iWordBegin - 1, 1) = "-" Then
                        If Rs!LeftOrRight = 0 Then '负债类科目特殊处理
                            If iMonth = 0 Then
                                dbl_Return = dbl_Return + ifAbs(SumRs!Yc, strTem)
                            Else
                                dbl_Return = dbl_Return + IIf(bPingJun = True, ifAbs(SumRs!Qc, strTem), ifAbs(SumRs!Qm, strTem))
                            End If
                        Else 'ifAbs
                            If iMonth = 0 Then
                                dbl_Return = dbl_Return + ifAbs(SumRs!Yc, strTem)
                            Else
                                dbl_Return = dbl_Return - IIf(bPingJun = True, SumRs!Qc, SumRs!Qm)
                            End If
                        End If
                    End If
                Else
                    If Rs!LeftOrRight = 0 Then '负债类科目特殊处理
                        If iMonth = 0 Then
                            dbl_Return = dbl_Return + ifAbs(SumRs!Yc, strTem)
                        Else
                            dbl_Return = dbl_Return + IIf(bPingJun = True, ifAbs(SumRs!Qc, strTem), ifAbs(SumRs!Qm, strTem))
                        End If
                    Else
                        If iMonth = 0 Then
                            dbl_Return = dbl_Return + ifAbs(SumRs!Yc, strTem)
                        Else
                            dbl_Return = dbl_Return + IIf(bPingJun = True, ifAbs(SumRs!Qc, strTem), ifAbs(SumRs!Qm, strTem))
                        End If
                    End If
                End If
            End If
            iWordBegin = i + 1
        End If
    Next
    GetSubVal = dbl_Return
End Function
Private Function ifAbs(ByVal dbl_backValue As Double, ByVal strTem As String) As Double
    If DEBUG_FLAG = False Then On Error Resume Next
    With CodeRs
        .MoveFirst
        .Find "cCode='" & strTem & "'"
        If !BalanceOri = "贷" Then
            ifAbs = -dbl_backValue
        Else
            ifAbs = dbl_backValue
        End If
    End With
End Function
'========================普通取值结束======================================================
Private Sub Class_Terminate()
    If DEBUG_FLAG = False Then On Error Resume Next
    If Rs.State = adStateOpen Then Rs.Close
    Set Rs = Nothing
    
    If CodeRs.State = adStateOpen Then CodeRs.Close
    Set CodeRs = Nothing
    
    Set Conn = Nothing
    
End Sub

						