frmtransferloss.frm

金算盘软件代码

    Set recType = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If Not recType.EOF Then
        Select Case recType!strVoucherFormat
        Case "1" ' 收款凭证 "
            lngFormatID = 54
        Case "2" ' 付款凭证
            lngFormatID = 55
        Case Else
            lngFormatID = 41
        End Select
    Else
        lngFormatID = 41
    End If
    recType.Close
    Set recType = Nothing
    mlngFormatID = lngFormatID
    
    'strCondVersion = " And (bytVersion Mod " & gVersionType * 2 & ">=" & gVersionType & ")"
    strCondVersion = " And (MOD(bytVersion," & gVersionType * 2 & ")>=" & gVersionType & ")"
    'strSql = "SELECT lngTemplateID, strTemplateName  From Template " _
           & "Where lngReceiptTypeID=" & lngFormatID & " And (Not blnIsInActive) " & strCondVersion _
           & " ORDER BY lngTemplateID"
    'Set lstxtTemplate.Recordset = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
    strSQL = "SELECT lngTemplateID, strTemplateName  From Template " _
           & "Where lngReceiptTypeID=" & lngFormatID & " And (blnIsInActive=0) " & strCondVersion _
           & " ORDER BY lngTemplateID"
    Set lstxtTemplate.Recordset = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    lstxtTemplate.Comparts = 2
    lstxtTemplate.AddRefer "<新增>"
    lstxtTemplate.AddRefer "<修改>"
    lstxtTemplate.AddRefer "<删除>"
    If lngID > 0 Then
        lstxtTemplate.SeekId lngID
        If lstxtTemplate.ID = 0 Then
            lstxtTemplate.ReferRow = 4
        End If
    Else
        If Not lstxtTemplate.Recordset Is Nothing Then
            lstxtTemplate.ReferRow = 4
        Else
            lstxtTemplate.Text = ""
        End If
    End If
End Sub

Private Sub RefreshRemark(Optional lngID As Long)
    Dim strSQL As String
    On Error Resume Next
    lstxtRemark.ClearRefer
    strSQL = "SELECT lngRemarkID,strRemarkName FROM Remark"
    'Set lstxtRemark.Recordset = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
    Set lstxtRemark.Recordset = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    lstxtRemark.Comparts = 2
    lstxtRemark.AddRefer "<新增>"
    lstxtRemark.AddRefer "<修改>"
    lstxtRemark.AddRefer "<删除>"
    If lngID > 0 Then
        lstxtRemark.SeekId lngID
    Else
        If Not lstxtRemark.Recordset Is Nothing Then
            lstxtRemark.ReferRow = 4
        Else
            lstxtRemark.Text = ""
        End If
    End If
End Sub

Private Sub mclsMainControl_EditShowList()
    lstxtAccount.Tag = msgAccount
    ShowRelationList
End Sub

'生成汇兑损益凭证
Private Function GenTransLossVoucher()
    Dim dtmStart As Date, dtmEnd As Date
    Dim lngCnt As Long, lngRow As Long
    Dim lngCurVoucher As Long, lngCntDetail As Long
    Dim dblAmount As Double, dblAdjustAmount As Double, dblCurrencyAmount As Double
    Dim blnTransLossMore As Boolean
    Dim qrfBalance As rdoQuery
    Dim strSQL As String
    Dim recTransLoss As rdoresultset
    Dim errNo As Long
    Dim strQAccountBalanceSql As String, strTmp As String
    Dim lngDebit As Long
    Dim lngCredit As Long
    
    On Error GoTo ErrHandle
    
    '结转期间
    gclsBase.FYearOfDate gclsBase.BaseDate, dtmStart
    gclsBase.PeriodOfDate gclsBase.BaseDate, , dtmEnd
    
    '初始凭证结构
    InitVoucherRecord VoucherData
    
    '生成单张凭证
    blnTransLossMore = False
    
    If blnTransLossMore Then
        ReDim VoucherData(msgRate.Rows - 1)
    Else
        ReDim VoucherData(0)
        ReDim VoucherData(0).Detail(0)
    End If
        
    '生成凭证
    strQAccountBalanceSql = TransferPublic.getQAccountBalanceOraSql(Format(dtmEnd, "yyyy-mm-dd"))
    strSQL = "SELECT Account.lngAccountID,lngCurrencyID,lngCustomerID,lngDepartmentID," _
        & "lngEmployeeID,lngClassID1,lngClassID2,intDirection," _
        & "(dblPostedDebit-dblPostedCredit) AS Amount," _
        & "(dblCurrencyPostedDebit-dblCurrencyPostedCredit) AS CurrencyAmount " _
        & "FROM (" & strQAccountBalanceSql & " ) QAccountBalance,Account " _
        & "WHERE QAccountBalance.lngAccountID=Account.lngAccountID(+) " _
        & "AND Account.blnIsCalcExchange=1 AND lngCurrencyID<>" & gclsBase.NaturalCurId
    Set recTransLoss = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    Do While Not recTransLoss.EOF
        For lngRow = 1 To msgRate.Rows - 1
            If CLng(msgRate.TextMatrix(lngRow, 0)) = recTransLoss!lngCurrencyID Then
                '是否生成多张凭证
                If blnTransLossMore Then
                    lngCurVoucher = lngRow
                Else
                    lngCurVoucher = 0
                End If
                With VoucherData(lngCurVoucher)
                    If Not .Used Then
                        .VoucherDate = Format(gclsBase.BaseDate, "YYYY-MM-DD")
                        .TemplateID = mTemplateID
                        .VoucherTypeID = mVoucherTypeID
                        .OperatorID = gclsBase.OperatorID
                        .CheckerID = 0
                        .PostID = 0
                        .VoucherSourceID = vsTransloss
                        ReDim .Detail(0)
                    End If
                
                    dblAmount = recTransLoss!Amount * recTransLoss!intDirection
                    dblCurrencyAmount = recTransLoss!CurrencyAmount * recTransLoss!intDirection
                    If msgRate.TextMatrix(lngRow, 4) Then
                        dblAdjustAmount = dblAmount - dblCurrencyAmount / CDbl(msgRate.TextMatrix(lngRow, 2))
                    Else
                        dblAdjustAmount = dblAmount - dblCurrencyAmount * CDbl(msgRate.TextMatrix(lngRow, 2))
                    End If
                    dblAdjustAmount = AdjustDec(dblAdjustAmount, gclsBase.NaturalCurDec)
                    If dblAdjustAmount <> 0 Then
                        If Not VoucherData(lngCurVoucher).Used Then
                            .Used = True
                            lngCntDetail = 0
                            ReDim Preserve VoucherData(lngCurVoucher).Detail(lngCntDetail)
                        Else
                            lngCntDetail = UBound(VoucherData(lngCurVoucher).Detail) + 1
                            ReDim Preserve VoucherData(lngCurVoucher).Detail(lngCntDetail)
                        End If
                        .Detail(lngCntDetail).Remark = lstxtRemark.Text
                        .Detail(lngCntDetail).AccountID = recTransLoss!lngAccountID
                        .Detail(lngCntDetail).CurrencyID = recTransLoss!lngCurrencyID
                        .Detail(lngCntDetail).ClassID1 = recTransLoss!lngClassID1
                        .Detail(lngCntDetail).ClassID2 = recTransLoss!lngClassID2
'                        .Detail(lngCntDetail).JobID = recTransLoss!lngJobID
                        .Detail(lngCntDetail).CustomerID = recTransLoss!lngCustomerID
                        .Detail(lngCntDetail).DepartmentID = recTransLoss!lngDepartmentID
                        .Detail(lngCntDetail).EmployeeID = recTransLoss!lngEmployeeID
                        If dblAdjustAmount > 0 Then
                            .Detail(lngCntDetail).Direction = recTransLoss!intDirection * (-1)
                            .Detail(lngCntDetail).Amount = dblAdjustAmount
                        Else
                            .Detail(lngCntDetail).Direction = recTransLoss!intDirection
                            .Detail(lngCntDetail).Amount = dblAdjustAmount * (-1)
                        End If
                        .Detail(lngCntDetail).Attribute = AccountAttribute(recTransLoss!lngAccountID)
                        .Detail(lngCntDetail).DetailEntry = (lngCurVoucher + 1) * 100 + lngCntDetail
                    End If
                End With
'                Exit For
            End If
        Next lngRow
        recTransLoss.MoveNext
    Loop
                    
    '生成汇兑损益结转科目
    For lngCnt = 0 To UBound(VoucherData)
        lngDebit = 0
        lngCredit = 0
        With VoucherData(lngCnt)
            If .Used Then
                dblAmount = 0
                For lngCntDetail = 0 To UBound(.Detail)
                    dblAmount = dblAmount + .Detail(lngCntDetail).Amount * .Detail(lngCntDetail).Direction
                    If .Detail(lngCntDetail).Direction = adDebit Then
                        lngDebit = lngDebit + 1
                    Else
                        lngCredit = lngCredit + 1
                    End If
                Next lngCntDetail
                If dblAmount <> 0 Then
                    lngCntDetail = UBound(.Detail) + 1
                    ReDim Preserve .Detail(lngCntDetail)
                    .Detail(lngCntDetail).Remark = lstxtRemark.Text
                    .Detail(lngCntDetail).AccountID = mAccountID
                    .Detail(lngCntDetail).Attribute = AccountAttribute(mAccountID)
                    If (.Detail(lngCntDetail).Attribute And aaDirection) = aaDirection Then
                        .Detail(lngCntDetail).Direction = adDebit
                        .Detail(lngCntDetail).Amount = dblAmount * (-1)
                        .Detail(lngCntDetail).DetailEntry = (lngCnt + 1) * 100 - 1
                    Else
                        .Detail(lngCntDetail).Direction = adCredit
                        .Detail(lngCntDetail).Amount = dblAmount
                        .Detail(lngCntDetail).DetailEntry = (lngCnt + 1) * 100 + lngCntDetail
                    End If
                    If .Detail(lngCntDetail).Direction = adDebit Then
                        lngDebit = lngDebit + 1
                    Else
                        lngCredit = lngCredit + 1
                    End If
                Else
                    If lngCntDetail = 1 Then
                        .Used = False
                    End If
                End If
                If lngDebit + lngCredit >= 2 Then
                    If lngDebit = 0 Then
                        For lngCntDetail = 0 To UBound(.Detail) - 1
                            .Detail(lngCntDetail).Amount = .Detail(lngCntDetail).Amount * (-1)
                            .Detail(lngCntDetail).Direction = adDebit
                        Next lngCntDetail
                    End If
                    If lngCredit = 0 Then
                        For lngCntDetail = 0 To UBound(.Detail) - 1
                            .Detail(lngCntDetail).Amount = .Detail(lngCntDetail).Amount * (-1)
                            .Detail(lngCntDetail).Direction = adCredit
                        Next lngCntDetail
                    End If
                End If
            End If
        End With
    Next lngCnt
    
    recTransLoss.Close
    Exit Function
    
ErrHandle:
    errNo = Errors.ErrorsDeal()
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case edtCanNotKnown
        ShowMsg hWnd, "程序出错：" & Err.Description, vbOKOnly + vbCritical, Caption
    End Select
    '清空凭证
    ReDim VoucherData(0)
    If Not recTransLoss Is Nothing Then recTransLoss.Close
'    If Not qrfBalance Is Nothing Then
'        qrfBalance.Close
'        Set qrfBalance = Nothing
'    End If
End Function
Private Function MakeTOReceipt() As Boolean
    Dim lngCnt As Long
    Dim strSQL As String
    Dim recDetail As rdoresultset
    Dim lngAccountNatureID As Long
    Dim lngTemplateID(1 To 6) As Long
    Dim intARDebit As Integer
    Dim intARCredit As Integer
    Dim intAPDebit As Integer
    Dim intAPCredit As Integer
    Dim intReceipt As Integer
    Dim intPayment As Integer
    
    MakeTOReceipt = True
    
    On Error GoTo Err_Handle
    
    intARDebit = 1
    intARCredit = 2
    intAPDebit = 3
    intAPCredit = 4
    intReceipt = 5
    intPayment = 6
    
    strSQL = "SELECT lngTemplateID,strTempLateName,lngReceiptTypeID FROM Template WHERE lngReceiptTypeID IN (34,35,36,37,39,40) ORDER BY lngReceiptTypeID,lngTemplateID"
    Set recDetail = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    Do While Not recDetail.EOF
        Select Case recDetail!lngReceiptTypeID
        Case 34
            If lngTemplateID(intAPCredit) = 0 Then
                If lngTemplateID(intAPCredit) = 0 Then lngTemplateID(intAPCredit) = -recDetail!lngTemplateID
            End If
            If lngTemplateID(intAPCredit) <= 0 And InStr(recDetail!strTempLateName, "复币") > 0 Then
                lngTemplateID(intAPCredit) = recDetail!lngTemplateID
            End If
        Case 35
            If lngTemplateID(intAPDebit) = 0 Then
                If lngTemplateID(intAPDebit) = 0 Then lngTemplateID(intAPDebit) = -recDetail!lngTemplateID
            End If
            If lngTemplateID(intAPDebit) <= 0 And InStr(recDetail!strTempLateName, "复币") > 0 Then
                lngTemplateID(intAPDebit) = recDetail!lngTemplateID
            End If
        Case 36
            If lngTemplateID(intARDebit) = 0 Then
                If lngTemplateID(intARDebit) = 0 Then lngTemplateID(intARDebit) = -recDetail!lngTemplateID
            End If
            If lngTemplateID(intARDebit) <= 0 And InStr(recDetail!strTempLateName, "复币") > 0 Then
                lngTemplateID(intARDebit) = recDetail!lngTemplateID
            End If
        Case 37
            If lngTemplateID(intARCredit) = 0 Then
                If lngTemplateID(intARCredit) = 0 Then lngTemplateID(intARCredit) = -recDetail!lngTemplateID
            End If
            If lngTemplateID(intARCredit) <= 0 And InStr(recDetail!strTempLateName, "复币") > 0 Then
                lngTemplateID(intARCredit) = recDetail!lngTemplateID
            End If
        Case 39
            If lngTemplateID(intPayment) = 0 Then
                If lngTemplateID(intPayment) = 0 Then lngTemplateID(intPayment) = -recDetail!lngTemplateID
            End If
            If lngTemplateID(intPayment) <= 0 And InStr(recDetail!strTempLateName, "复币") > 0 Then
                lngTemplateID(intPayment) = recDetail!lngTemplateID
            End If
        Case 40
            If lngTemplateID(intReceipt) = 0 Then
                If lngTemplateID(intReceipt) = 0 Then lngTemplateID(intReceipt) = -recDetail!lngTemplateID
            End If
            If lngTemplateID(intReceipt) <= 0 And InStr(recDetail!strTempLateName, "复币") > 0 Then
                lngTemplateID(intReceipt) = recDetail!lngTemplateID
            End If
        End Select
        recDetail.MoveNext
    Loop
    recDetail.Close
    
    With VoucherData(0)
        If VoucherData(0).Saved Then
            For lngCnt = 0 To UBound(.Detail) - 1
                strSQL = "SELECT lngAccountNatureID FROM Account WHERE lngAccountID=" & .Detail(lngCnt).AccountID
                Set recDetail = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
                If Not recDetail.EOF Then
                    If recDetail!lngAccountNatureID >= 1 Or recDetail!lngAccountNatureID <= 4 Then
                        If recDetail!lngAccountNatureID = 1 Or recDetail!lngAccountNatureID = 2 Then
                            With .Detail(lngCnt)
                                If .Amount * .Direction > 0 Then
                                    If Not AddReceipt(.AccountID, lstxtAccount.ID, .CurrencyID, .CustomerID, .DepartmentID, _
                                        .EmployeeID, .ClassID1, .ClassID2, Abs(.Amount * .Direction), lngTemplateID(intReceipt), 40, 40) Then
                                        MakeTOReceipt = False
                                        Exit For
                                    End If
                                Else
                                    If Not AddReceipt(.AccountID, lstxtAccount.ID, .CurrencyID, .CustomerID, .DepartmentID, _
                                        .E