accassi.cls

VB开发的ERP系统

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "AccAssi"
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"
'****************************************************************
'*    模 块 名 称 :系统用于辅助核算中的查询
'*    功 能 描 述 :
'*    程序员姓名  :白石军
'*    最后修改人  :
'*    最后修改时间:2001/12/30
'*
'*    1。部门总帐
'*    2。个人余额表
'*    3。客户余额表
'*    4。供应商余额表
'*
'*    调用方法：在写入网格前
'*    Dim clsAccAss As New AccAssi
'*    With clsAccAss
'*      .iPeriod_Begin = Int_BPeriod  '查询会计期开始
'*      .iPeriod_End = Int_EPeriod    '查询会计期结束
'*      .iPeriod_Year = Int_Year      '查询会计年
'*      .b_Keep_Business_Records = Bln_IncluNotBook  '是否包含记帐凭证
'*      .PayTypes = Dep   '常量,Dep：部门，Per个人，Cur：客户，Ven：供应商
'*      .sPayCode = Str_FzCode  '部门、个人、客户或供应商代码，不分类。
'*    End With
'*    Set Rec_Query = clsAccAss.GetNewRs()
'*    最后在Form_UnLoad() 中销毁此对象 Set clsAccAssi=Nothing
'*    备        注:程序中所有依实际情况自定义部分均用[>>  <<]括起
'****************************************************************

Option Explicit
Const DEBUG_FLAG = True '调试标志，发布时设为False

Const FIRST_MEMBER = 1 '第一个成员，用于集合的循环变量

Const DEPT_CODE = &H100 '表示部门往来的常量
Const CURS_CODE = &H200 '表示客户往来的常量
Const VEND_CODE = &H300 '表示供应商往来的常量
Const PERS_CODE = &H400 '表示个人往来的常量
'-------------------------------------------
Const QI_CU_YU_E = &H500 '表示期初余额的常量
Const BEN_QI_FA_SHENG_E = &H600 '表示本期发生额的常量
Const LEI_JI_FA_SHENG_E = &H700 '表示累计发生额的常量
'-------------------------------------------
Public Enum Account_Book_Type '帐类型，如期初余额、期末余额等
    QiCu = QI_CU_YU_E '期初余额
    BenQi = BEN_QI_FA_SHENG_E '本期发生额
    LeiJi = LEI_JI_FA_SHENG_E '累计发生额
End Enum
'-------------------------------------------
Public Enum PAST_VALUE '用于传递参数据的数据类型
    Dep = DEPT_CODE '部门往来
    Cur = CURS_CODE '客户往来
    Per = PERS_CODE '个人往来
    Ven = VEND_CODE '供应商往来
End Enum
'------------------------------------------------------
Private AccType As Account_Book_Type  '类型，期初、期末、本期等

Public iPeriod_Begin As Integer '起始会计期间

Public iPeriod_End As Integer '终止会计期间

Public iPeriod_Year As Integer '会计年度

Public b_Keep_Business_Records As Boolean '是否包含末记帐凭证 True包含,False不包含

Public PayTypes As PAST_VALUE '辅助核算类型，如：部门往来、客户往来等

Public sPayCode As String '核算代码，如部门代码、客户代码等
'--------------------------------------------------------
Public PayRs As New ADODB.Recordset '核算基记录集，也是最终返回的记录集，可对其数值进行加减

Private AddRs As New ADODB.Recordset '相加记录集，将此记录集累加到基记录集上，几次累加后得到最终结果
'-------------------------------------------

Private sCodingPlan As String '科目编码方案

'---由于字段名可能不同，而此模块要应用于四个查询窗体，及数据表中，所以引入此法-----------
'   在 MeInit 过程中根据传递参数 AccType 设置这些值
Private CodeFlagFerldName As String 'Cwzz_AccCode（科目表）中标记往来的字段名
Private AssiCodeFeildName As String 'Cwzz_SumAssi（辅助帐）中标记往来代码的字段名
Private VouchCodeFeildName As String 'Cwzz_Vouch（凭证子表）中标记往来代码的字段名
'--------------------------------------------------------------------------------
Private CodeList As New Collection '用于存放会计科目列表的集合（最终数据）
Private TemCodeListAssi As New Collection '临时存放会计科目列表的集合
Private TemCodeListVouch As New Collection '临时存放会计科目列表的集合

Public Function GetNewRs() As ADODB.Recordset
    '公共接口
    '供外部程序调用的方法，并返回新的记录集
    If DEBUG_FLAG = False Then On Error Resume Next
    
    Call MeInit '初始化字段名
    
    Call GetAssiCodeList '取辅助核算表中有记录的科目列表
    
    If b_Keep_Business_Records = True Then '如果包含末记帐凭证
        Call GetVouchCodeList '则取凭证表中有发生的科目列表
    End If
    
    Call MakeCodeList '由临时集合1、2生成新的会计科目列表（集合中科目有唯一性）
    
    '------------生成期初数据------------------------------------
    AccType = QiCu '标记设为“期初”
    
    Call MakePayRs '生成基记录集
    
    Call GetSumAssi '生成期初数据
    Call AddTowRs '相加已取得的两个记录集
    
    
    If b_Keep_Business_Records = True Then '如果包含末记帐凭证
        Call GetVouchRs '则取末记帐凭证生成相加记录集
        Call AddTowRs '相加已取得的两个记录集
    End If
    '------------------------------------------------------------
    
    '------------生成本期发生数据--------------------------------
    AccType = BenQi '标记设为“本期”
    
    Call GetSumAssi '生成本期数据
    Call AddTowRs '相加已取得的两个记录集
    
    If b_Keep_Business_Records = True Then '如果包含末记帐凭证
        Call GetVouchRs '则取末记帐凭证生成相加记录集
        Call AddTowRs '相加已取得的两个记录集
    End If
    '--------------------------------------------------------------
    
    '--------------生成累计发生额----------------------------------
    AccType = LeiJi '标记设为“累计”
    
    Call GetSumAssi '生成累计数据
    Call AddTowRs '相加已取得的两个记录集
    
    If b_Keep_Business_Records = True Then '如果包含末记帐凭证
        Call GetVouchRs '则取末记帐凭证生成相加记录集
        Call AddTowRs '相加已取得的两个记录集
    End If
    '----------------------------
    
    Set GetNewRs = PayRs '返回最新的记录集
End Function

Private Sub Class_Initialize()
    '取得科目代码编码方案
    If DEBUG_FLAG = False Then On Error Resume Next
    Dim temRs As ADODB.Recordset
    Set temRs = Cw_DataEnvi.DataConnect.Execute("select * from Gy_CodeScheme where ItemCode='Cwzz_kmcode'")
    sCodingPlan = Trim(temRs!codescheme)
    temRs.Close
    Set temRs = Nothing
    
End Sub

Private Sub Class_Terminate()
    '销毁对象
    On Error Resume Next
    
    Set CodeList = Nothing
    Set TemCodeListAssi = Nothing
    Set TemCodeListVouch = Nothing
    
    If PayRs.State <> adStateClosed Then PayRs.Close
    If AddRs.State <> adStateClosed Then AddRs.Close
    
    Set PayRs = Nothing
    Set AddRs = Nothing
    
End Sub

Private Sub GetAssiCodeList() '取辅助核算表中有记录的科目列表
    '有过发生额的科目被取出，并存放于临时集合“TemCodeListAssi”中，
    '此集合中的科目将最终被加入到“CodeList”中用来生成查询语句
    '生成的查询语名格式为：cCode='xxx1" or cCode='xxx2" or cCode='xxx3" ……
    
    If DEBUG_FLAG = False Then On Error Resume Next
    Dim temRs As New ADODB.Recordset
    Dim strSql As String
    strSql = "SELECT DISTINCT cCode FROM Cwzz_AccSumAssi WHERE " & AssiCodeFeildName & " like '" & sPayCode & "%'"
    
    Set temRs = Cw_DataEnvi.DataConnect.Execute(strSql)
    
    With temRs
        If .EOF And .BOF Then Exit Sub
        
        Dim strCode As String
        Dim iLen As Integer
        Dim iCutLen As Integer
        Dim strTem As String
        Do Until .EOF
            '--根据编码方案取出科目代码及其上级科目代码---------
            strCode = Trim(!Ccode)
            iLen = 1
            iCutLen = 0
            Do While (iCutLen < Len(strCode))
                iCutLen = iCutLen + Mid(sCodingPlan, iLen, 1) 'sCodingPlan 为编码方案
                strTem = Left(strCode, iCutLen)
                TemCodeListAssi.Add Trim(strTem)
                iLen = iLen + 1
            Loop
            '-------------------------------------------------
            .MoveNext
        Loop
    End With
    temRs.Close
    Set temRs = Nothing
End Sub

Private Sub GetVouchCodeList() '则取凭证表中有发生的科目列表
    If DEBUG_FLAG = False Then On Error Resume Next
    Dim temRs As New ADODB.Recordset
    Dim strSql As String
    strSql = "SELECT DISTINCT cCode FROM Cwzz_AccVouchSub WHERE " & AssiCodeFeildName & " like '" & sPayCode & "%'"
    
    Set temRs = Cw_DataEnvi.DataConnect.Execute(strSql)
    
    With temRs
        If .EOF And .BOF Then Exit Sub
        
        Dim strCode As String
        Dim iLen As Integer
        Dim iCutLen As Integer
        Dim strTem As String
        Do Until .EOF
            '---------------------------------------------------
            strCode = Trim(!Ccode)
            iLen = 1
            iCutLen = 0
            Do While (iCutLen < Len(strCode))
                iCutLen = iCutLen + Mid(sCodingPlan, iLen, 1)
                strTem = Left(strCode, iCutLen)
                TemCodeListVouch.Add Trim(strTem)
                iLen = iLen + 1
            Loop
            '-------------------------------------------------
            .MoveNext
        Loop
    End With
    temRs.Close
    Set temRs = Nothing
End Sub

Private Sub MakeCodeList() '由临时集合1、2生成新的会计科目列表（集合中科目有唯一性）
    If DEBUG_FLAG = False Then On Error Resume Next
    Dim i As Integer
    Dim j As Integer
    Dim temRs As New ADODB.Recordset
    Dim strSql As String
    
    Dim bIsHere As Boolean
    '-----------------------------------------------------
    For i = FIRST_MEMBER To TemCodeListAssi.count
        bIsHere = False
        For j = FIRST_MEMBER To CodeList.count
            If CodeList.Item(j) = TemCodeListAssi.Item(i) Then
                bIsHere = True
                Exit For
            End If
        Next j
        
        If bIsHere = False Then
            CodeList.Add TemCodeListAssi.Item(i)
        End If
    Next i
    '-----------------------------------------------------
    For i = FIRST_MEMBER To TemCodeListVouch.count
        bIsHere = False
        For j = FIRST_MEMBER To CodeList.count
            If CodeList.Item(j) = TemCodeListVouch.Item(i) Then
                bIsHere = True
                Exit For
            End If
        Next j
        If bIsHere = False Then
            CodeList.Add TemCodeListVouch.Item(i)
        End If
        
    Next i
    
    For i = CodeList.count To FIRST_MEMBER Step -1
        strSql = "SELECT " & CodeFlagFerldName & " FROM Cwzz_AccCode WHERE cCode='" & CodeList.Item(i) & "'"
        If temRs.State <> adStateClosed Then temRs.Close
        Set temRs = Cw_DataEnvi.DataConnect.Execute(strSql)
        If temRs.Fields(CodeFlagFerldName).Value = False Then
            CodeList.Remove (i)
        End If
    Next
    
End Sub

Private Sub MakePayRs() '生成基记录集
    If DEBUG_FLAG = False Then On Error Resume Next
    Dim strTemSql As String
    Dim i As Integer
    strTemSql = ""
    strTemSql = "SELECT  Cwzz_AccCode.cCode," '    /* 科目代码 */
    strTemSql = strTemSql & "Cwzz_AccCode.cName," '   /* 科目名称*/
    strTemSql = strTemSql & "Cwzz_AccCode.EndFlag," '   /*末级标志*/
    strTemSql = strTemSql & "IsNull(Cwzz_AccSum.Period,1) as Period," '/*/
    
    strTemSql = strTemSql & "Cwzz_AccSum.Qcye as QcyeHj," ' /* 期初余额*/
    strTemSql = strTemSql & "Cwzz_AccSum.Qcsl as QcslHj," '/*期初数量*/
    strTemSql = strTemSql & "Cwzz_AccSum.Qcwb as QcwbHj," '/*期初外币*/
    
    strTemSql = strTemSql & "Byjfljje as ByjfljjeHj," ' /*本月借方累计金额合计*/
    strTemSql = strTemSql & "Bydfljje as BydfljjeHj," ' /*本月贷方累计金额合计*/
    strTemSql = strTemSql & "Byjfljwb as ByjfljwbHj," ' /*本月借方累计外币合计*/