企业管理

开发平台：
Visual Basic

clsInc.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 = "clsInc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*********************************************************************
'*    模 块 名 称 :财务分析损益表表计算分析类模块
'*    功 能 描 述 :
'*    程序员姓名  :白石军
'*    最后修改人  :
'*    最后修改时间:2002/1/21
'*    备        注:程序中所有依实际情况自定义部分均用[>>  <<]括起
'*
'*********************************************************************
Option Explicit
Private Const SQL = "SELECT * FROM cwfx_IncomeCostInitial"
Private bSomeThingWrong As Boolean '有错误
Private CodeRs As New ADODB.Recordset '会计科目
Private Conn As New ADODB.Connection '数据连接
Private Rs As New ADODB.Recordset '记录集
Private sItem As String '项目
Private iMonthBegin As Integer '月首
Private iMonthEnd As Integer '月末
Private iYear As Integer '年
Private iThisMonthBegin As Integer
Private iThisMonthEnd As Integer
Private iCompMonthBegin As Integer
Private iCompMonthEnd As Integer
Private iThisYear As Integer
Private iCompYear As Integer
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 = PastConn
        .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 = GetPeriodValue(strItem, 0, 0, iYear)
End Function
Public Function GetPeriodValue(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
    iMonthBegin = intPeriodBegin
    iMonthEnd = intPeriodEnd
    iYear = intYear
    GetPeriodValue = GetVal(strItem)
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
    dbl_FirstValue = GetPeriodValue(strItem, intPeriodBegin, intPeriodEnd, iYear)
    dbl_EndValue = GetPeriodValue(strItem, intPeriodBegin, intPeriodEnd, iYear)
    GetAveragePeriodValue = (dbl_FirstValue + dbl_EndValue) / 2
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 opTem As String '加减号
    Dim dbl_RetVal As Double '加数或减数
    Dim strSubExp As String
    Dim i As Integer
    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)
                            
                            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 IsNull(Sum(Mjje),0) AS jje ,IsNull(Sum(Mdje),0) AS dje FROM Cwzz_AccSum Where cCode='" & strTem & "'"
            strSql = strSql & " AND Year=" & iYear
            strSql = strSql & " AND Period BETWEEN " & iMonthBegin & " AND " & iMonthEnd
            
            
            Set SumRs = Cw_DataEnvi.DataConnect.Execute(strSql)
            
            If Not (SumRs.EOF And SumRs.BOF) Then
                CodeRs.MoveFirst
                CodeRs.Find "cCode='" & strTem & "'"
                If Not CodeRs.EOF Then
                    If iWordBegin > 1 Then
                        If Mid(strSubExp, iWordBegin - 1, 1) = "+" Then
                            '----------------------
                            dbl_Return = dbl_Return + Val(IIf(Trim(CodeRs!BalanceOri) = "借", SumRs!jje & "", SumRs!dje & ""))
                            '----------------------
                        ElseIf Mid(strSubExp, iWordBegin - 1, 1) = "-" Then
                            '------------------
                            dbl_Return = dbl_Return - Val(IIf(Trim(CodeRs!BalanceOri) = "借", SumRs!jje & "", SumRs!dje & ""))
                            '----------------
                        End If
                    Else
                        '-----------------------
                        dbl_Return = dbl_Return + Val(IIf(Trim(CodeRs!BalanceOri) = "借", SumRs!jje & "", SumRs!dje & ""))
                        '-----------------------
                    End If
                End If
            End If
            iWordBegin = i + 1
        End If
    Next
    GetSubVal = dbl_Return
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
    Set Conn = Nothing
End Sub

						