frmexpense.frm

金算盘软件代码

    Dim dblAmount As Double
    Dim lngAccountID As Long
    Dim errNo As Long
    Dim strQAccountBalanceSql As String, strTmp As String
    
    On Error GoTo ErrHandle
    strRemark = "管理费用分摊"
    '结转期间
    gclsBase.PeriodOfDate gclsBase.BaseDate, , dtmEnd
    strCode1 = AccountCode(ltxtAcc1.ID)
    
    strQAccountBalanceSql = TransferPublic.getQAccountBalanceOraSql(Format(dtmEnd, "yyyy-mm-dd"))
    strSql = "SELECT Account.lngAccountID,lngCustomerID,lngDepartmentID," _
        & "lngEmployeeID,lngClassID1,lngClassID2,intDirection,strAccountCode," _
        & "SUM(dblPostedDebit-dblPostedCredit) AS Amount " _
        & "FROM ( " & strQAccountBalanceSql & " ) QAccountBalance,Account " _
        & "WHERE QAccountBalance.lngAccountID=Account.lngAccountID " _
        & "AND Instr(strAccountCode,'" & strCode1 & "-')=1 " _
        & "GROUP BY Account.lngAccountID,strAccountCode,lngCustomerID,lngDepartmentID," _
        & "lngEmployeeID,lngClassID1,lngClassID2,intDirection,strAccountCode"
    Set recLoss = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recLoss.EOF Then
        recLoss.Close
        GenVoucher = False
        Exit Function
    End If
    
    '初始凭证结构
    '医疗支出
    intVoucher = 0
    InitVoucher VoucherData(intVoucher)
    If ltxtAcc20.ID > 0 Then
        strCode2 = AccountCode(ltxtAcc20.ID)
        recLoss.MoveFirst
        Do While Not recLoss.EOF
            strCode = strCode2 & Mid(recLoss!strAccountCode, Len(strCode1) + 1, 30)
            lngAccountID = AccountCodeID(strCode)
            If lngAccountID > 0 Then
                With VoucherData(intVoucher)
                    If Not .Used Then
                        .VoucherDate = Format(gclsBase.BaseDate, "YYYY-MM-DD")
                        .TemplateID = ltxtTemplate.ID
                        .VoucherTypeID = ltxtType.ID
                        .OperatorID = gclsBase.OperatorID
                        .CheckerID = 0
                        .PostID = 0
                        .VoucherSourceID = vsTransfer
                        ReDim Preserve .Detail(0)
                    End If
                    
                    If C2Dbl(spinRate0.Text) + C2Dbl(spinRate1.Text) = 100 And intVoucher = 1 Then
                        dblAmount = AdjustDec(recLoss!Amount * C2Dbl(spinRate0.Text) / 100, gclsBase.NaturalCurDec)
                        dblAmount = AdjustDec(recLoss!Amount - dblAmount, gclsBase.NaturalCurDec)
                    Else
                        dblAmount = AdjustDec(recLoss!Amount * C2Dbl(spinRate0.Text) / 100, gclsBase.NaturalCurDec)
                    End If
                    If dblAmount <> 0 Then
                        If Not VoucherData(intVoucher).Used Then
                            .Used = True
                            lngCntDetail = 0
                            ReDim Preserve .Detail(lngCntDetail)
                        Else
                            lngCntDetail = UBound(.Detail) + 1
                            ReDim Preserve .Detail(lngCntDetail)
                        End If
                        '转入科目
                        .Detail(lngCntDetail).Remark = strRemark
                        .Detail(lngCntDetail).AccountID = lngAccountID
                        .Detail(lngCntDetail).ClassID1 = recLoss!lngClassID1
                        .Detail(lngCntDetail).ClassID2 = recLoss!lngClassID2
                        .Detail(lngCntDetail).CustomerID = recLoss!lngCustomerID
                        .Detail(lngCntDetail).DepartmentID = recLoss!lngDepartmentID
                        .Detail(lngCntDetail).EmployeeID = recLoss!lngEmployeeID
    '                            If dblAmount > 0 Then
                            .Detail(lngCntDetail).Direction = recLoss!intDirection
                            .Detail(lngCntDetail).Amount = dblAmount * recLoss!intDirection
    '                            Else
    '                                .Detail(lngCntDetail).Direction = recLoss!intDirection * -1
    '                                .Detail(lngCntDetail).Amount = -dblAmount
    '                            End If
                        .Detail(lngCntDetail).Attribute = AccountAttribute(lngAccountID)
                        '管理费用科目
                        lngCntDetail = UBound(.Detail) + 1
                        ReDim Preserve .Detail(lngCntDetail)
                        .Detail(lngCntDetail).Remark = strRemark
                        .Detail(lngCntDetail).AccountID = recLoss!lngAccountID
                        .Detail(lngCntDetail).ClassID1 = recLoss!lngClassID1
                        .Detail(lngCntDetail).ClassID2 = recLoss!lngClassID2
                        .Detail(lngCntDetail).CustomerID = recLoss!lngCustomerID
                        .Detail(lngCntDetail).DepartmentID = recLoss!lngDepartmentID
                        .Detail(lngCntDetail).EmployeeID = recLoss!lngEmployeeID
    '                            If dblAmount > 0 Then
                            .Detail(lngCntDetail).Direction = recLoss!intDirection * -1
                            .Detail(lngCntDetail).Amount = dblAmount * recLoss!intDirection
    '                            Else
    '                                .Detail(lngCntDetail).Direction = recLoss!intDirection
    '                                .Detail(lngCntDetail).Amount = dblAmount * (-1)
    '                            End If
                        .Detail(lngCntDetail).Attribute = AccountAttribute(recLoss!lngAccountID)
                    End If
                End With
            End If
            recLoss.MoveNext
        Loop
    End If
                    
    '药品支出
    intVoucher = 1
    InitVoucher VoucherData(intVoucher)
    If ltxtAcc21.ID > 0 Then
        strCode2 = AccountCode(ltxtAcc21.ID)
        recLoss.MoveFirst
        Do While Not recLoss.EOF
            strCode = strCode2 & Mid(recLoss!strAccountCode, Len(strCode1) + 1, 30)
            lngAccountID = AccountCodeID(strCode)
            If lngAccountID > 0 Then
                With VoucherData(intVoucher)
                    If Not .Used Then
                        .VoucherDate = Format(gclsBase.BaseDate, "YYYY-MM-DD")
                        .TemplateID = ltxtTemplate.ID
                        .VoucherTypeID = ltxtType.ID
                        .OperatorID = gclsBase.OperatorID
                        .CheckerID = 0
                        .PostID = 0
                        .VoucherSourceID = vsTransfer
                        ReDim Preserve .Detail(0)
                    End If
                    
                    If C2Dbl(spinRate0.Text) + C2Dbl(spinRate1.Text) = 100 And intVoucher = 1 Then
                        dblAmount = AdjustDec(recLoss!Amount * C2Dbl(spinRate0.Text) / 100, gclsBase.NaturalCurDec)
                        dblAmount = AdjustDec(recLoss!Amount - dblAmount, gclsBase.NaturalCurDec)
                    Else
                        dblAmount = AdjustDec(recLoss!Amount * C2Dbl(spinRate1.Text) / 100, gclsBase.NaturalCurDec)
                    End If
                    If dblAmount <> 0 Then
                        If Not VoucherData(intVoucher).Used Then
                            .Used = True
                            lngCntDetail = 0
                            ReDim Preserve .Detail(lngCntDetail)
                        Else
                            lngCntDetail = UBound(.Detail) + 1
                            ReDim Preserve .Detail(lngCntDetail)
                        End If
                        '转入科目
                        .Detail(lngCntDetail).Remark = strRemark
                        .Detail(lngCntDetail).AccountID = lngAccountID
                        .Detail(lngCntDetail).ClassID1 = recLoss!lngClassID1
                        .Detail(lngCntDetail).ClassID2 = recLoss!lngClassID2
                        .Detail(lngCntDetail).CustomerID = recLoss!lngCustomerID
                        .Detail(lngCntDetail).DepartmentID = recLoss!lngDepartmentID
                        .Detail(lngCntDetail).EmployeeID = recLoss!lngEmployeeID
    '                            If dblAmount > 0 Then
                            .Detail(lngCntDetail).Direction = recLoss!intDirection
                            .Detail(lngCntDetail).Amount = dblAmount * recLoss!intDirection
    '                            Else
    '                                .Detail(lngCntDetail).Direction = recLoss!intDirection * -1
    '                                .Detail(lngCntDetail).Amount = -dblAmount
    '                            End If
                        .Detail(lngCntDetail).Attribute = AccountAttribute(lngAccountID)
                        '管理费用科目
                        lngCntDetail = UBound(.Detail) + 1
                        ReDim Preserve .Detail(lngCntDetail)
                        .Detail(lngCntDetail).Remark = strRemark
                        .Detail(lngCntDetail).AccountID = recLoss!lngAccountID
                        .Detail(lngCntDetail).ClassID1 = recLoss!lngClassID1
                        .Detail(lngCntDetail).ClassID2 = recLoss!lngClassID2
                        .Detail(lngCntDetail).CustomerID = recLoss!lngCustomerID
                        .Detail(lngCntDetail).DepartmentID = recLoss!lngDepartmentID
                        .Detail(lngCntDetail).EmployeeID = recLoss!lngEmployeeID
    '                            If dblAmount > 0 Then
                            .Detail(lngCntDetail).Direction = recLoss!intDirection * -1
                            .Detail(lngCntDetail).Amount = dblAmount * recLoss!intDirection
    '                            Else
    '                                .Detail(lngCntDetail).Direction = recLoss!intDirection
    '                                .Detail(lngCntDetail).Amount = dblAmount * (-1)
    '                            End If
                        .Detail(lngCntDetail).Attribute = AccountAttribute(recLoss!lngAccountID)
                    End If
                End With
            End If
            recLoss.MoveNext
        Loop
    End If
                    
    '转入制剂科目
    intVoucher = 2
    InitVoucher VoucherData(intVoucher)
    If mblnAcc22IsDetail Then
        intVoucher = 2
        InitVoucher VoucherData(intVoucher)
        If ltxtAcc22.ID > 0 And C2Dbl(spinRate2.Text) > 0 Then
            dblBalance = 0
            recLoss.MoveFirst
            lngCntDetail = 0
            Do While Not recLoss.EOF
                With VoucherData(intVoucher)
                    If Not .Used Then
                        .VoucherDate = Format(gclsBase.BaseDate, "YYYY-MM-DD")
                        .TemplateID = ltxtTemplate.ID
                        .VoucherTypeID = ltxtType.ID
                        .OperatorID = gclsBase.OperatorID
                        .CheckerID = 0
                        .PostID = 0
                        .VoucherSourceID = vsTransfer
                        ReDim Preserve .Detail(0)
                        .Detail(0).Remark = strRemark
                        .Detail(0).AccountID = ltxtAcc22.ID
                        .Detail(0).Attribute = AccountAttribute(ltxtAcc22.ID)
                        .Detail(0).Direction = adDebit
                        lngCntDetail = 1
                        ReDim Preserve .Detail(lngCntDetail)
                    End If
                    
                    If C2Dbl(spinRate0.Text) + C2Dbl(spinRate1.Text) + C2Dbl(spinRate2.Text) = 100 Then
                        dblAmount = AdjustDec(recLoss!Amount * C2Dbl(spinRate0.Text) / 100, gclsBase.NaturalCurDec)
                        dblAmount = dblAmount + AdjustDec(recLoss!Amount * C2Dbl(spinRate1.Text) / 100, gclsBase.NaturalCurDec)
                        dblAmount = AdjustDec(recLoss!Amount - dblAmount, gclsBase.NaturalCurDec)
                    Else
                        dblAmount = AdjustDec(recLoss!Amount * C2Dbl(spinRate2.Text) / 100, gclsBase.NaturalCurDec)
                    End If
                    dblBalance = dblBalance + dblAmount
                    If dblAmount <> 0 Then
                        If Not VoucherData(intVoucher).Used Then
                            .Used = True
'                            lngCntDetail = 0
                            ReDim Preserve .Detail(lngCntDetail)
                        Else
                            lngCntDetail = UBound(.Detail) + 1
                            ReDim Preserve .Detail(lngCntDetail)
                        End If
                        '管理费用科目
                        .Detail(lngCntDetail).Remark = strRemark
                        .Detail(lngCntDetail).AccountID = recLoss!lngAccountID
                        .Detail(lngCntDetail).ClassID1 = recLoss!lngClassID1
                        .Detail(lngCntDetail).ClassID2 = recLoss!lngClassID2
                        .Detail(lngCntDetail).CustomerID = recLoss!lngCustomerID
                        .Detail(lngCntDetail).DepartmentID = recLoss!lngDepartmentID
                        .Detail(lngCntDetail).EmployeeID = recLoss!lngEmployeeID
    '                    If dblAmount > 0 Then
                            .Detail(lngCntDetail).Direction = recLoss!intDirection * -1
                            .Detail(lngCntDetail).Amount = dblAmount * recLoss!intDirection
    '                    Else
    '                        .Detail(lngCntDetail).Direction = recLoss!intDirection
    '                        .Detail(lngCntDetail).Amount = dblAmount * (-1)
    '                    End If
                        .Detail(lngCntDetail).Attribute = AccountAttribute(recLoss!lngAccountID)
                    End If
                End With
                recLoss.MoveNext
            Loop
            VoucherData(intVoucher).Detail(0).Amount = dblBalance
        End If
    Else
        intVoucher = 2
        InitVoucher VoucherData(intVoucher)
        If ltxtAcc22.ID > 0 Then
            strCode2 = AccountCode(ltxtAcc22.ID)
            recLoss.MoveFirst
            Do While Not recLoss.EOF
                strCode = strCode2 & Mid(recLoss!strAccountCode, Len(strCode1) + 1, 30)
                lngAccountID = AccountCodeID(strCode)
                If lngAccountID > 0 Then
                    With VoucherData(intVoucher)
                        If Not .Used Then
                            .VoucherDate = Format(gclsBase.BaseDate, "YYYY-MM-DD")
                            .TemplateID = ltxtTemplate.ID
                            .VoucherTypeID = ltxtType.ID
                            .OperatorID = gclsBase.OperatorID
                            .CheckerID = 0
                            .PostID = 0
                            .VoucherSourceID = vsTransfer
                            ReDim Preserve .Detail(0)
                        End If
                        
                        If C2Dbl(spinRate0.Text) + C2Dbl(spinRate1.Text) + C2Dbl(spinRate2.Text) = 100 Then
                            dblAmount = AdjustDec(recLoss!Amount * C2Dbl(spinRate0.Text) / 100, gclsBase.NaturalCurDec)
                            dblAmount = dblAmount + AdjustDec(recLoss!Amount * C2Dbl(spinRate1.Text) / 100, gclsBase.NaturalCurDec)
                            dblAmount = AdjustDec(recLoss!Amount - dblAmount, gclsBase.NaturalCurDec)
                        Else
                            dblAmount = AdjustDec(recLoss!Amount * C2Dbl(spinRate2.Text) / 100, gclsBase.NaturalCurDec)
                        End If
                        If dblAmount <> 0 Then
                            If Not VoucherData(intVoucher).Used Then
                                .Used = True
                                lngCntDetail = 0
                                ReDim Preserve .Detail(lngCntDetail)
                            Else
                                lngCntDetail = UBound(.Detail) + 1
                                ReDim Preserve .Detail(lngCntDetail)
                            End If
                            '转入科目
                            .Detail(lngCntDetail).Remark = strRemark
                            .Detail(lngCntDetail).AccountID = lngAccountID
                            .Detail(lngCntDetail).ClassID1 = recLoss!lngClassID1
                            .Detail(lngCntDetail).ClassID2 = recLoss!lngClassID2
                            .Detail(lngCntDetail).CustomerID = recLoss!lngCustomerID
                            .Detail(lngCntDetail).DepartmentID = recLoss!lngDepartmentID
                            .Detail(lngCntDetail).EmployeeID = recLoss!lngEmployeeID
        '                            If dblAmount > 0 Then
                                .Detail(lngCntDetail).Direction = recLoss!intDirection
                                .Detail(lngCntDetail).Amount = dblAmount * recLoss!intDirection
        '                            Else
        '                                .Detail(lngCntDetail).Direction = recLoss!intDirection * -1
        '                                .Detail(lngCntDetail).Amount = -dblAmount
        '                            End If
                            .Detail(lngCntDetail).Attribute = AccountAttribute(lngAccountID)
                            '管理费用科目
                            lngCntDetail = UBound(.Detail) + 1
                            ReDim Preserve .Detail(lngCntDetail)
                            .Detail(lngCntDetail).Remark = strRemark
                            .Detail(lngCntDetail).AccountID = recLoss!lngAccountID
                            .Detail(lngCntDetail).ClassID1 = recLoss!lngClassID1
                            .Detail(lngCntDetail).ClassID2 = recLoss!lngClassID2
                            .Detail(lngCntDetail).CustomerID = recLoss!lngCustomerID
                            .Detail(lngCntDetail).DepartmentID = recLoss!lngDepartmentID
                            .Detail(lngCntDetail).EmployeeID = recLoss!lngEmployeeID
        '                            If dblAmount > 0 Then
                                .Detail(lngCntDetail).Direction = recLoss!intDirection * -1
                                .Detail(lngCntDetail).Amount = dblAmount * recLoss!intDirection
        '                            Else
        '                                .Detail(lngCntDetail).Direction = recLoss!intDirection
        '                                .Detail(lngCntDetai