maketrans.cls

金算盘软件代码

            lngCustomerID_MJ = recTemp_Trans!lngCustomerID
            lngDepartmentID_MJ = recTemp_Trans!lngDepartmentID
            lngEmployeeID_MJ = recTemp_Trans!lngEmployeeID
            '''lngJobID_MJ = recTemp_Trans!lngJobID
            lngClassID1_MJ = recTemp_Trans!lngClassID1
            lngClassID2_MJ = recTemp_Trans!lngClassID2
            lngCurNow = recTemp_Trans!lngCurrencyID
            intDirection = recTemp_Trans!intDirection
            '2)调用公式判断本科目的计算公式包括了哪些核算项目的条件(调用WR)
            strFunc = ""
            strCurrFunc = ""
            strQuanFunc = ""
            If Trim(recTemp_Trans!strAmountFormula) <> "" Then '金额公式
                strFunc = recTemp_Trans!strAmountFormula
            End If
            If Trim(recTemp_Trans!strCurrencyFormula) <> "" Then '外币公式
                strCurrFunc = recTemp_Trans!strCurrencyFormula
            End If
            If Trim(recTemp_Trans!strQuantityFormula) <> "" Then '数量公式
                strQuanFunc = recTemp_Trans!strQuantityFormula
            End If
            If CalFunction(strFunc, strCurrFunc, strQuanFunc, arrAccount(), lngTransVoucherID, lngTransVoucherDetailID, _
                           strAccountId, lngCustomerID_MJ, lngDepartmentID_MJ, lngEmployeeID_MJ, lngJobID_MJ, _
                           lngClassID1_MJ, lngClassID2_MJ, intDirection, lngCurNow) = False Then
                mintSub = 0
                Exit Function
            End If
            recTemp_Account.MoveNext
        Loop
        Set recTemp_Account = Nothing

        recTemp_Trans.MoveNext
    Loop
    Set recTemp_Trans = Nothing
    
    TransVoucher = GetTransIN
End Function

Private Sub InitArr(varArr As Variant, ByVal lngResult As Integer)
   Dim intCount As Integer
        
        For intCount = 0 To 6
            varArr(intCount) = False
        Next intCount
        If (lngResult And 1) <> 0 Then '科目条件
            varArr(0) = True
        End If
        If (lngResult And 2) <> 0 Then  '单位条件
            varArr(1) = True
        End If
        If (lngResult And 4) <> 0 Then '部门条件
            varArr(2) = True
        End If
        If (lngResult And 8) <> 0 Then '员工条件
            varArr(3) = True
        End If
        If (lngResult And 16) <> 0 Then '工程条件
            varArr(4) = True
        End If
        If (lngResult And 32) <> 0 Then  '统计条件
            varArr(5) = True
        End If
        If (lngResult And 256) <> 0 Then '项目条件
            varArr(6) = True
        End If
End Sub

'参数：strFunction 计算公式
'      intType 公式类型：1、金额公式  2、外币公式 3、数量公式
'算法说明：
'    如果会计科目具有某种核算属性：当通用转帐模板中给该属性赋值，则直接使用；否则，查询出该属性所有的可能值
Private Function CalFunction(NatureFunc As String, CurrencyFunc As String, QuantityFunc As String, arrAccount() As Boolean, _
                             lngTransVoucherID As Long, lngTransVoucherDetailID As Long, strAccountId As String, lngCustomerID_MJ As Long, lngDepartmentID_MJ As Long, lngEmployeeID_MJ As Long, lngJobID_MJ As Long, lngClassID1_MJ As Long, lngClassID2_MJ As Long, intDirection As Integer, Optional lngCurID As Long = 0) As Boolean
    
    Dim strSql As String
    Dim strCustomerID As String
    Dim strDepartmentID As String
    Dim strEmployeeID As String
    Dim strJobID As String
    Dim strClassID1 As String
    Dim strClassID2 As String
    
    Dim recTemp_1 As rdoResultset
    Dim recTemp_2 As rdoResultset
    Dim recTemp_3 As rdoResultset
    Dim recTemp_4 As rdoResultset
    Dim recTemp_5 As rdoResultset
    Dim recTemp_6 As rdoResultset
    
    Dim blnFirst As Boolean
    Dim intLoopLevel As Integer
    Dim intEditLevel As Integer
    Dim strFun As String '
    Dim dblValue As Double     '通用转帐公式计算出的“本币”结果
    Dim dblCurrValue As Double '通用转帐公式计算出的“原币”结果
    Dim dblQuanValue As Double '通用转帐公式计算出的“数量”结果
 
    Dim lngResult As Long
    Dim blnOK As Boolean
    
    Dim i As Integer
    Dim arrSelect(7) As Boolean '设置条件的核算项目
    Dim arrSelect2(7) As Boolean '设置条件的核算项目
                   
            '用于调试时，将theDebug设置为True
            
            lngResult = mclsBaseFun.SetCurrentCond(NatureFunc)
            
            InitArr arrSelect, lngResult
            
            If arrSelect(1) = False And arrSelect(2) = False And arrSelect(3) = False And arrSelect(4) = False And arrSelect(5) = False And arrSelect(6) = False Then
                strCustomerID = lngCustomerID_MJ
                strDepartmentID = lngDepartmentID_MJ
                strEmployeeID = lngEmployeeID_MJ
                strJobID = lngJobID_MJ
                strClassID1 = lngClassID1_MJ
                strClassID2 = lngClassID2_MJ
                
                dblValue = mclsBaseFun.EvalueFunc(NatureFunc, blnOK, strAccountId * Abs(arrSelect(0)), strCustomerID * Abs(arrSelect(1)), strDepartmentID * Abs(arrSelect(2)), _
                                                  strEmployeeID * Abs(arrSelect(3)), strJobID * Abs(arrSelect(4)), strClassID1 * Abs(arrSelect(5)), lngCurID, , strClassID2 * Abs(arrSelect(6)))
                If CurrencyFunc <> "" Then
                    lngResult = mclsBaseFun.SetCurrentCond(CurrencyFunc)
                    InitArr arrSelect2, lngResult
                    dblCurrValue = mclsBaseFun.EvalueFunc(CurrencyFunc, blnOK, strAccountId * Abs(arrSelect2(0)), strCustomerID * Abs(arrSelect2(1)), strDepartmentID * Abs(arrSelect2(2)), _
                                                      strEmployeeID * Abs(arrSelect2(3)), strJobID * Abs(arrSelect2(4)), strClassID1 * Abs(arrSelect2(5)), lngCurID, , strClassID2 * Abs(arrSelect2(6)))
                End If
                If QuantityFunc <> "" Then
                    lngResult = mclsBaseFun.SetCurrentCond(QuantityFunc)
                    InitArr arrSelect2, lngResult
                    dblQuanValue = mclsBaseFun.EvalueFunc(QuantityFunc, blnOK, strAccountId * Abs(arrSelect2(0)), strCustomerID * Abs(arrSelect2(1)), strDepartmentID * Abs(arrSelect2(2)), _
                                                      strEmployeeID * Abs(arrSelect2(3)), strJobID * Abs(arrSelect2(4)), strClassID1 * Abs(arrSelect2(5)), lngCurID, , strClassID2 * Abs(arrSelect2(6)))
                End If
                If blnOK = False Then Exit Function
                
                dblValue = Val(Format(dblValue, gclsBase.GetFormat(gclsBase.NaturalCurDec)))
                If dblValue <> 0 Then  '将数据写入临时表
                    If Not WriteTemp(arrAccount(), arrSelect(), lngTransVoucherID, lngTransVoucherDetailID, strAccountId, strCustomerID, strDepartmentID, strEmployeeID, strJobID, strClassID1, strClassID2, intDirection, dblValue, dblCurrValue, dblQuanValue) Then Exit Function
                End If
                CalFunction = True
                Exit Function
            End If
            
            '3)逐级展开

            intEditLevel = 0
            intLoopLevel = 0
            blnFirst = True

            strCustomerID = "0"
            strDepartmentID = "0"
            strEmployeeID = "0"
            strJobID = "0"
            strClassID1 = "0"
            strClassID2 = "0"

            '1------------------------------------------------------------------------
            Do
                If arrSelect(1) Then  '如果科目包括本层的核算项目，则打开所有的核算明细记录
                    If lngCustomerID_MJ <> 0 Then '本科目为末级科目，且具有本种核算属性，并已具体设置了条件值
                        If intLoopLevel = 0 Then
                            strCustomerID = lngCustomerID_MJ
                            intLoopLevel = 1
                        Else
                            Exit Do                            '------------本层由内层退出时调用（直接退出本层循环）
                        End If
                    Else
                        If blnFirst Then '                      ------------本层第一次调用（打开记录集）
                            strSql = "SELECT Customer.* FROM Customer"
                            Set recTemp_1 = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                            If recTemp_1.BOF And recTemp_1.EOF Then
                                arrSelect(1) = False '记录集为空，相当于不包括本层核算
                            Else
                                recTemp_1.MoveFirst
                                strCustomerID = recTemp_1(0)
                            End If
                        Else
                            If intLoopLevel = 0 Then '         ------------本层由外层调用（需将记录集移到开始处）
                                recTemp_1.MoveFirst
                                strCustomerID = recTemp_1(0)
                            Else                            '  ------------本层由内层退出时调用（移动已打开的记录集的指针到下条记录）
                                If Not recTemp_1.EOF Then
                                    recTemp_1.MoveNext