transferpubic.bas

金算盘软件代码

    Dim errNo As Long
    Dim recVoucher As rdoResultset
    Dim blnErr As Boolean
    Dim lngVoucherID As Long
    Dim lngVoucherDetailID As Long
    
'    For lngCnt = 0 To UBound(VoucherData.Detail)
'        With VoucherData.Detail(lngCnt)
'            Debug.Print .DetailEntry & " " & .Next & " " & .AccountID & " " & .Direction & " " & .Amount
'        End With
'    Next lngCnt
    
    '检查凭证合法性
    ValidVoucher VoucherData, strFrom
    blnErr = False
    
    On Error GoTo ErrHandle
    
    If VoucherData.Used And Not VoucherData.IsError Then
        intYear = gclsBase.FYearOfDate(VoucherData.VoucherDate)
        intPeriod = gclsBase.PeriodOfDate(VoucherData.VoucherDate)
        strVolume = FindVolume(VoucherData.VoucherTypeID, intYear, bytPeriod, VoucherData.VoucherNO)
        For lngCntDetail = 0 To UBound(VoucherData.Detail)
            With VoucherData.Detail(lngCntDetail)
                If .Direction = adDebit Then
                    If Len(strDebitAccount) < 255 Then
                        If strDebitAccount = "" Then
                            strDebitAccount = AccountCode(.AccountID, True)
                        Else
                            strDebitAccount = strDebitAccount & "/" & AccountCode(.AccountID, True)
                        End If
                    End If
                Else
                    If Len(strCreditAccount) < 255 Then
                        If strCreditAccount = "" Then
                            strCreditAccount = AccountCode(.AccountID, True)
                        Else
                            strCreditAccount = strCreditAccount & "/" & AccountCode(.AccountID, True)
                        End If
                    End If
                End If
                If .CurrencyID > 0 And (.CurrencyAmount <> 0 Or .Amount <> 0) Then
                    If .CurrencyAmount = 0 And VoucherData.VoucherSourceID <> vsTransloss Then
                        .CurrencyAmount = .Amount
                    ElseIf .Amount = 0 Then
                        .Amount = .CurrencyAmount
                    End If
                    If .Amount <> 0 And .CurrencyAmount <> 0 Then
                        If DirectRate(.CurrencyID) Then
                            .Rate = .Amount / .CurrencyAmount
                        Else
                            .Rate = .CurrencyAmount / .Amount
                        End If
                    End If
                End If
                If .CurrencyID = 0 Then
                    .CurrencyAmount = .Amount
                    .CurrencyID = gclsBase.NaturalCurId
                    .Rate = 1
                End If
                If .Quantity <> 0 And .CurrencyAmount <> 0 Then
                    .Price = .CurrencyAmount / .Quantity
                End If
            End With
        Next lngCntDetail
        lngVoucherID = GetNewID("Voucher")
        lngCnt = 0
        While lngCnt < 5
            strSql = "INSERT INTO Voucher(lngVoucherID,intYear,bytPeriod,strDate,lngTemplateID,intNumber,lngVoucherTypeID,strVolume," _
                & "intVoucherNo,lngOperatorID,lngCheckerID,lngPostID,lngVoucherSourceID,blnIsPrint,strDebitAccountCode," _
                & "strCreditAccountCode) " _
                & "VALUES(" & lngVoucherID & "," & intYear & "," & intPeriod & ",'" & Format(VoucherData.VoucherDate, "yyyy-mm-dd") & "'," _
                & VoucherData.TemplateID & "," & VoucherData.Number & "," & VoucherData.VoucherTypeID & ",'" & strVolume & "'," _
                & VoucherData.VoucherNO & "," & VoucherData.OperatorID & "," & VoucherData.CheckerID & "," _
                & VoucherData.PostID & "," & VoucherData.VoucherSourceID & "," & VoucherData.IsPrint & ",'" _
                & Trim(strLeft(strDebitAccount, 255)) & "','" & Trim(strLeft(strCreditAccount, 255)) & "')"
            blnErr = Not gclsBase.ExecSQL(strSql)
            If blnErr Then
                If lngCnt < 5 Then
                    lngCnt = lngCnt + 1
                    VoucherData.VoucherNO = VoucherData.VoucherNO + 1
                End If
            Else
                lngCnt = 5
            End If
        Wend
        If Not blnErr Then
            strSql = "SELECT lngVoucherID FROM Voucher WHERE intYear=" & intYear & " AND bytPeriod=" & intPeriod _
                & " AND lngVoucherTypeID=" & VoucherData.VoucherTypeID & " AND intVoucherNo=" & VoucherData.VoucherNO _
                & " AND lngVoucherSourceID=" & VoucherData.VoucherSourceID
            Set recVoucher = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If Not recVoucher.EOF Then
                VoucherData.VoucherID = recVoucher!lngVoucherID
            End If
            recVoucher.Close
            Set recVoucher = Nothing
        End If
        
        lngRowno = 1
        With VoucherData
            For lngCntDetail = 0 To UBound(.Detail)
                lngCntDetailNo = 999999
                lngNextDetail = 999999
                For lngCntDetail0 = 0 To UBound(.Detail)
                    If .Detail(lngCntDetail0).DetailEntry > 0 Then
                        If .Detail(lngCntDetail0).DetailEntry < lngCntDetailNo And _
                            Not .Detail(lngCntDetail0).Saved Then
                           lngCntDetailNo = .Detail(lngCntDetail0).DetailEntry
                           lngNextDetail = lngCntDetail0
                        End If
                    End If
                Next lngCntDetail0
                lngCntDetailNo = lngNextDetail
                If lngCntDetailNo <= UBound(.Detail) Then
                    Do While lngCntDetailNo > -1
                        If .Detail(lngCntDetailNo).AccountID > 0 And .Detail(lngCntDetailNo).Amount <> 0 Then
                            Select Case .SourceVoucherID
                            Case 1
                                If .Detail(lngCntDetailNo).Direction = adDebit Then
                                    lngRowno = 1
                                Else
                                    If lngRowno = 1 Then lngRowno = 2
                                End If
                            Case 2
                                If .Detail(lngCntDetailNo).Direction = adCredit Then
                                    lngRowno = 1
                                Else
                                    If lngRowno = 1 Then lngRowno = 2
                                End If
                            End Select
                            lngVoucherDetailID = GetNewID("VoucherDetail")
                            strSql = "INSERT INTO VoucherDetail(lngVoucherDetailID,lngVoucherID,lngRowID,strRemark,lngAccountID," _
                                & "intDirection,dblAmount,lngCurrencyID,dblRate,dblCurrencyAmount,dblQuantity," _
                                & "dblPrice,lngCustomerID,lngDepartmentID,lngEmployeeID,lngClassID1,lngClassID2) " _
                                & "VALUES(" & lngVoucherDetailID & "," & .VoucherID & "," & lngRowno & ",'" & strLeft(.Detail(lngCntDetailNo).Remark, 40) & "'," _
                                & .Detail(lngCntDetailNo).AccountID & "," & .Detail(lngCntDetailNo).Direction & "," _
                                & .Detail(lngCntDetailNo).Amount & "," & .Detail(lngCntDetailNo).CurrencyID & "," _
                                & .Detail(lngCntDetailNo).Rate & "," & .Detail(lngCntDetailNo).CurrencyAmount & "," _
                                & .Detail(lngCntDetailNo).Quantity & "," & .Detail(lngCntDetailNo).Price & "," _
                                & .Detail(lngCntDetailNo).CustomerID & "," & .Detail(lngCntDetailNo).DepartmentID & "," _
                                & .Detail(lngCntDetailNo).EmployeeID & "," & .Detail(lngCntDetailNo).ClassID1 & "," _
                                & .Detail(lngCntDetailNo).ClassID2 & ")"
                            blnErr = blnErr Or (Not gclsBase.ExecSQL(strSql))
                            lngRowno = lngRowno + 1
                        End If
                        .Detail(lngCntDetailNo).Saved = True
                        lngCntDetailNo = .Detail(lngCntDetailNo).Next
                        If lngCntDetailNo = 0 Then lngCntDetailNo = -1
                    Loop
                End If
            Next lngCntDetail
            For lngCntDetail = 0 To UBound(.Detail)
                If Not .Detail(lngCntDetail).Saved Then
                    If .Detail(lngCntDetail).AccountID > 0 And .Detail(lngCntDetail).Amount <> 0 Then
                        Select Case .SourceVoucherID
                        Case 1
                            If .Detail(lngCntDetail).Direction = adDebit Then
                                lngRowno = 1
                            Else
                                If lngRowno = 1 Then lngRowno = 2
                            End If
                        Case 2
                            If .Detail(lngCntDetail).Direction = adCredit Then
                                lngRowno = 1
                            Else
                                If lngRowno = 1 Then lngRowno = 2
                            End If
                        End Select
                        lngVoucherDetailID = GetNewID("VoucherDetail")
                        strSql = "INSERT INTO VoucherDetail(lngVoucherDetailID,lngVoucherID,lngRowID,strRemark,lngAccountID," _
                            & "intDirection,dblAmount,lngCurrencyID,dblRate,dblCurrencyAmount,dblQuantity," _
                            & "dblPrice,lngCustomerID,lngDepartmentID,lngEmployeeID,lngClassID1,lngClassID2) " _
                            & "VALUES(" & lngVoucherDetailID & "," & .VoucherID & "," & lngRowno & ",'" & strLeft(.Detail(lngCntDetail).Remark, 40) & "'," _
                            & .Detail(lngCntDetail).AccountID & "," & .Detail(lngCntDetail).Direction & "," _
                            & .Detail(lngCntDetail).Amount & "," & .Detail(lngCntDetail).CurrencyID & "," _
                            & .Detail(lngCntDetail).Rate & "," & .Detail(lngCntDetail).CurrencyAmount & "," _
                            & .Detail(lngCntDetail).Quantity & "," & .Detail(lngCntDetail).Price & "," _
                            & .Detail(lngCntDetail).CustomerID & "," & .Detail(lngCntDetail).DepartmentID & "," _
                            & .Detail(lngCntDetail).EmployeeID & "," & .Detail(lngCntDetail).ClassID1 & "," _
                            & .Detail(lngCntDetail).ClassID2 & ")"
                        blnErr = blnErr Or (Not gclsBase.ExecSQL(strSql))
                        lngRowno = lngRowno + 1
                    End If
                End If
            Next lngCntDetail
            '更新科目余额
            If Not blnErr Then
                If Not ChangeAllAccount_from_Voucher("I", VoucherData.VoucherID) Then
                    blnErr = True
                End If
            Else
                strSql = "DELETE FROM Voucher WHERE lngVoucherID=" & VoucherData.VoucherID
                gclsBase.ExecSQL strSql
                strSql = "DELETE FROM VoucherDetail WHERE lngVoucherID=" & VoucherData.VoucherID
                gclsBase.ExecSQL strSql
            End If
            If blnErr Then
                .VoucherID = -1
                .IsError = True
                .ErrorString = "存盘失败！"
            End If
            .Saved = (.VoucherID > 0) And (Not blnErr)
        End With
    End If
    If VoucherData.Saved Then
        lngVoucherCnt = lngVoucherCnt + 1
    End If
    SaveOneVoucher = (lngVoucherCnt > 0)
    Exit Function
    
ErrHandle:
    errNo = Errors.ErrorsDeal()
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case Else
        'gclsBase.BaseWorkSpace.RollBack
'        gclsBase.BaseWorkSpace.RollBacktrans
        ShowMsg 0, "程序出错：" & Err.Description, vbOKOnly + vbCritical, "保存机制转帐凭证"
    End Select
   
End Function

'生成凭证的合法性
Public Sub ValidVoucher(VoucherData As VoucherRecord, Optional strFrom As String)
    Dim lngCnt As Long, lngDetail As Long
    Dim dblDebit As Double, dblCredit As Double, dblAmount As Double
    Dim lngDebit As Long, lngCredit As Long
    Dim strRemark As String
    Dim lngBalance As Long
    Dim strSql As String
    Dim recType As rdoResultset
    
    If VoucherData.VoucherSourceID <> vsFixedAlter Then
        VoucherMustNo VoucherData
    End If
    
    If gclsBase.PeriodClosed(VoucherData.VoucherDate) And IsDate(VoucherData.VoucherDate) Then
        VoucherData.IsError = True
        VoucherData.ErrorString = VoucherData.VoucherDate & "所在期间已结帐，不能生成凭证！"
    End If
    
    If VoucherData.Used And Not VoucherData.IsError Then
        dblDebit = 0
        dblCredit = 0
        dblAmount = 0
        lngDebit = 0
        lngCredit = 0
        lngBalance = -1
        For lngDetail = 0 To UBound(VoucherData.Detail)
            With VoucherData.Detail(lngDetail)
                strRemark = Trim$(.Remark)
                strRemark = Replace(strRemark, "'", "’")
                strRemark = Replace(strRemark, """", "”")
                Do While StrLen(strRemark) > 40
                    strRemark = Left$(strRemark, Len(strRemark) - 1)
                Loop
                .Remark = IIf(strRemark = "", " ", strRemark)
                If .Balance Then
                    lngBalance = lngDetail
                End If
                dblAmount = dblAmount + Abs(.Amount)
                Select Case .Direction
                Case adDebit
                    dblDebit = dblDebit + .Amount
                    lngDebit = lngDebit + 1
                Case adCredit
                    dblCredit = dblCredit + .Amount
                    lngCredit = lngCredit + 1
                Case Else
                    '借贷方向
                    VoucherData.IsError = True
                    If .Amount <> 0 Then
                        VoucherData.ErrorString = "凭证分录未指定借贷方向！"
                    Else
                        If strFrom = "商品业务" Then
                            VoucherData.ErrorString = "没有金额可生成凭证(若是发票(单据)请检查对应单据(发票)是否已制作凭证)！"
                        Else
                            VoucherData.ErrorString = "没有金额可生成凭证！"
                        End If
                    End If
                    Exit For
                End Select
                '科目
                If .AccountID = 0 Then
                    VoucherData.IsError = True
                    VoucherData.ErrorString = "凭证分录未指定科目！"
                    Exit For
                End If
                '明细科目
                If (.Attribute And aaDetail) <> aaDetail Then
                    VoucherData.IsError = True
                    VoucherData.ErrorString = AccountCode(.AccountID) & "是非明细科目！"
                    Exit For
                End If
                '停用科目
                If .AccountID > 0 And (.Attribute And aaActive) <> aaActive Then
                    VoucherData.IsError = True
                    VoucherData.ErrorString = AccountCode(.AccountID) & "已经停用！"
                    Exit For
                End If
                '分录辅助核算属性
                If VoucherData.VoucherSourceID <> vsFixedAlter Then
                    If (.Attribute And aaCustomer) = aaCustomer Then
                        If .CustomerID = 0 Then
                            VoucherData.IsError = True
                            VoucherData.ErrorString = "未指定科目" & AccountCode(.AccountID) & "的核算单位！"
                            Exit For
                        End If
                    End If
                    If (.Attribute And aaDepartment) = aaDepartment Then
                        If .DepartmentID = 0 Then
                            VoucherData.IsError = True
                            VoucherData.ErrorString = "未指定科目" & AccountCode(.AccountID) & "的核算部门！"
                            Exit For
                        End If
                    End If
                    If (.Attribute And aaEmployee) = aaEmployee Then