discount.bas

金算盘软件代码

Attribute VB_Name = "Discount"
'本模快用于计算
'1 商品折扣：DiscountItem
'2 贴息折扣：DiscountPayMent
'3 批量折扣：DiscountBatch
'4 促销折扣：DiscountSale
'5 客户折扣：DiscountCustomer
Option Explicit

Public Type PayMentDiscInfo
    lngRowno As Long                '行号
    lngTableID As Long              '表ID
    lngActivityDetailID As Long     '明细ID
    dblUsedAmount As Double         '已用金额
    dblSavedAmount As Double        '已核销金额(已存盘)
    dblDiscountRate As Double       '扣率
    strDate As String               '日期
End Type

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'商品折扣
'
'lngItemID     ：折扣商品ID
'dblTotalAmount：折扣前金额
'dblAmount     ：折扣后金额
'dblDiscount   ：折扣金额
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function DiscountItem(ByVal lngItemID As Long, ByVal dblTotalAmount, dblAmount As Double, dblDiscount As Double) As Boolean
    Dim strSQL As String
    Dim recItem As rdoResultset
    
    On Error GoTo ErrHandle
    
    strSQL = "SELECT dblItemDiscRate FROM Item WHERE lngItemID=" & lngItemID
    Set recItem = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If Not recItem.EOF Then
        dblAmount = dblTotalAmount * recItem!dblItemDiscRate / 100
        dblDiscount = dblTotalAmount - dblAmount
    Else
        dblAmount = dblTotalAmount
        dblDiscount = 0
    End If
    recItem.Close
    Set recItem = Nothing
    DiscountItem = True
    Exit Function
    
ErrHandle:
    Set recItem = Nothing
    DiscountItem = False
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'批量折扣
'
'lngItemID     ：折扣商品ID
'dblQuantity   ：数量
'dblTotalAmount：折扣前金额
'dblAmount     ：折扣后金额
'dblDiscount   ：折扣金额
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function DiscountBatch(ByVal lngItemID As Long, ByVal dblQuantity As Double, ByVal dblTotalAmount, _
    dblAmount As Double, dblDiscount As Double) As Boolean
    
    dblAmount = dblTotalAmount * BatchDiscountRate(lngItemID, dblQuantity, dblTotalAmount + dblAmount)
    dblDiscount = dblTotalAmount - dblAmount
    DiscountBatch = True
End Function

Public Function BatchDiscountRate(ByVal lngItemID As Long, ByVal dblQuantity As Double, ByVal dblAmount As Double) As Double
    Dim strSQL As String
    Dim ItemQuanDisc As rdoResultset
    
    On Error GoTo ErrHandle
    
    strSQL = "SELECT dblDiscountRate FROM ItemQuanDisc WHERE ROWNUM=1 AND lngItemID=" & lngItemID _
        & " AND (dblQuantity<=" & dblQuantity & " OR dblAmount<=" & dblAmount & ") ORDER BY dblDiscountRate"
    Set ItemQuanDisc = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If Not ItemQuanDisc.EOF Then
        BatchDiscountRate = ItemQuanDisc!dblDiscountRate / 100
    Else
        BatchDiscountRate = 1
    End If
    ItemQuanDisc.Close
    Set ItemQuanDisc = Nothing
'    BatchDiscountRate = True
    Exit Function
    
ErrHandle:
    Set ItemQuanDisc = Nothing
    BatchDiscountRate = 1
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'促销折扣
'
'lngItemID     ：折扣商品ID
'strDate       ：日期
'dblTotalAmount：折扣前金额
'dblAmount     ：折扣后金额
'dblDiscount   ：折扣金额
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function DiscountSale(ByVal lngItemID As Long, ByVal strDate As String, ByVal dblTotalAmount, _
    dblAmount As Double, dblDiscount As Double) As Boolean
    
    dblAmount = dblTotalAmount * SaleDiscountRate(lngItemID, strDate)
    dblDiscount = dblTotalAmount - dblAmount
    DiscountSale = True
End Function

Public Function SaleDiscountRate(ByVal lngItemID As Long, ByVal strDate As String) As Double
    Dim strSQL As String
    Dim ItemSaleDisc As rdoResultset
    
    On Error GoTo ErrHandle
    
    strSQL = "SELECT ItemSaleDiscDetail.dblDiscountRate FROM ItemSaleDiscDetail,ItemSaleDisc " _
        & "WHERE ItemSaleDiscDetail.lngItemSaleDiscID=ItemSaleDisc.lngItemSaleDiscID " _
        & "AND lngItemID=" & lngItemID & " AND ' '||Ltrim(strStartDate)<=' " & LTrim(strDate) _
        & "' AND ' '||Ltrim(strEndDate)>=' " & LTrim(strDate) & "'"
    Set ItemSaleDisc = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If Not ItemSaleDisc.EOF Then
        SaleDiscountRate = ItemSaleDisc!dblDiscountRate / 100
    Else
        SaleDiscountRate = 1
    End If
    ItemSaleDisc.Close
    Set ItemSaleDisc = Nothing
'    SaleDiscountRate = True
    Exit Function
    
ErrHandle:
    Set ItemSaleDisc = Nothing
    SaleDiscountRate = 1
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'客户折扣
'
'lngCustomerID ：客户ID
'dblTotalAmount：折扣前金额
'dblAmount     ：折扣后金额
'dblDiscount   ：折扣金额
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function DiscountCustomer(ByVal lngCustomerID As Long, ByVal dblTotalAmount, dblAmount As Double, dblDiscount As Double) As Boolean
    Dim strSQL As String
    Dim recCustomer As rdoResultset
    
    On Error GoTo ErrHandle
    
    strSQL = "SELECT dblDiscountRate FROM Customer WHERE lngCustomerID=" & lngCustomerID
    Set recCustomer = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If Not recCustomer.EOF Then
        dblAmount = dblTotalAmount * recCustomer!dblDiscountRate / 100
        dblDiscount = dblTotalAmount - dblAmount
    Else
        dblAmount = dblTotalAmount
        dblDiscount = 0
    End If
    recCustomer.Close
    Set recCustomer = Nothing
    DiscountCustomer = True
    Exit Function
    
ErrHandle:
    Set recCustomer = Nothing
    DiscountCustomer = False
End Function



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''贴息折扣
'
'lngCustomerID ：客户ID
'strDate       ：日期
'lngItemID     ：商品ID
'dblQuantity   ：折扣前金额
'dblPayAmount  ：实际支付金额
'dblPayDiscount：折扣金额
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Public Function DiscountPayment(ByVal lngCustomerID As Long, ByVal strDate As String, ByVal lngItemID As Long, _
'    ByVal lngCurrencyID As Long, ByVal dblQuantity As Double, ByVal dblNoDiscAmount As Double, dblPayAmount As Double, _
'    dblPayDiscount As Double, ByVal lngRowNO As Long, GrdCol As MSFlexGrid) As Boolean

'    Dim strSql As String
'    Dim strTmp As String
'    Dim recItem As rdoResultset
'    Dim recCustomer As rdoResultset
'    Dim recTmp As rdoResultset
'    Dim dblNoDiscPrice As Double
'    Dim dblSalePrice As Double
'    Dim dblCurrAmount As Double
'    Dim dblNoDiscCurrAmount As Double
'    Dim dblAmount As Double
'    Dim dblDiscount As Double
'    Dim dblDiscRate As Double
'    Dim DiscInfos() As PayMentDiscInfo
'    Dim DiscInfosOther() As PayMentDiscInfo
'    Dim dblTmp As Double
'
'    On Error GoTo ErrHandle
'    ReDim DiscInfos(0)
'    If C2lng(grdCol.TextMatrix(lngRowNo, 0)) <> 0 Then
'        strTmp = Trim(grdCol.TextMatrix(lngRowNo, grdCol.Cols - 1))
'
'        Do While strTmp <> ""
'            ReDim Preserve DiscInfos(UBound(DiscInfos) + 1)
'            DiscInfos(UBound(DiscInfos)).lngRowNo = lngRowNo
'            DiscInfos(UBound(DiscInfos)).lngTableID = C2lng(ShareString(strTmp, ","))
'            DiscInfos(UBound(DiscInfos)).lngActivityDetailID = C2lng(ShareString(strTmp, ","))
'            DiscInfos(UBound(DiscInfos)).dblUsedAmount = C2Dbl(ShareString(strTmp, ","))
'            DiscInfos(UBound(DiscInfos)).dblDiscountRate = C2Dbl(ShareString(strTmp, ","))
'            DiscInfos(UBound(DiscInfos)).strDate = ShareString(strTmp, ",")
'            strTmp = Trim(strTmp)
'            Select Case bytDiscInfoErr(DiscInfos(UBound(DiscInfos)), C2lng(grdCol.TextMatrix(lngRowNo, 0)), lngCurrencyID, lngCustomerID, dblTmp)
'            Case 1
'                ReDim Preserve DiscInfos(UBound(DiscInfos) - 1)
'            Case 2
'
'            End Select
'        Loop
'    End If
'    grdCol.TextMatrix(lngRowNo, grdCol.Cols - 1) = ""
'    GetPayMentDiscInfo grdCol, DiscInfosOther(), lngCurrencyID, lngCustomerID
'
'
'    '实际付款金额及可获折扣
'    dblPayAmount = 0
'    dblPayDiscount = 0
'
'    '实际销售货款：打折金额和不打折金额部分
'    dblCurrAmount = dblQuantity
'    dblNoDiscCurrAmount = dblNoDiscAmount
'    grdCol.TextMatrix(lngRowNo, grdCol.Cols - 1) = ""
'    strSql = "SELECT blnIsPayDiscount,lngARAccountID FROM Customer WHERE lngCustomerID=" & lngCustomerID
'    Set recCustomer = gclsBase.BaseDB.openResultset(strSql, rdOpenStatic)
'    If Not recCustomer.EOF Then
'        If recCustomer!blnIsPayDiscount And recCustomer!lngARAccountID > 0 Then
'            With gclsBase.BaseDB.QueryDefs("QItemPayDisc")
'                .Parameters("AccountID") = recCustomer!lngARAccountID
'                .Parameters("CurrencyID") = lngCurrencyID
'                .Parameters("ItemID") = lngItemID
'                .Parameters("EndDate") = strDate
'                Set recTmp = .openResultset(rdOpenStatic)
'            End With
'            Do While Not recTmp.EOF
'                dblTmp = UsedAmount(DiscInfosOther, C2lng(recTmp!strTabID), recTmp!lngActivityDetailID)
'                If dblCurrAmount > recTmp!dblCurRestAmount + recTmp!dblCurrDiscount - dblTmp Then
'                    dblTmp = (recTmp!dblCurRestAmount + recTmp!dblCurrDiscount - dblTmp) / (recTmp!dblCurRestAmount + recTmp!dblCurrDiscount)
'                    dblAmount = recTmp!dblCurRestAmount * dblTmp
'                    dblDiscount = recTmp!dblCurrDiscount * dblTmp
'                    dblPayAmount = dblPayAmount + recTmp!dblCurRestAmount * dblTmp
'                    dblPayDiscount = dblPayDiscount + recTmp!dblCurrDiscount * dblTmp
'                    dblCurrAmount = dblCurrAmount - (dblAmount + dblDiscount)
'                Else
'                    dblAmount = recTmp!dblCurRestAmount * dblCurrAmount / (recTmp!dblCurRestAmount + recTmp!dblCurrDiscount)
'                    dblDiscount = recTmp!dblCurrDiscount * dblCurrAmount / (recTmp!dblCurRestAmount + recTmp!dblCurrDiscount)
'                    dblPayAmount = dblPayAmount + dblAmount
'                    dblPayDiscount = dblPayDiscount + dblDiscount
'                    dblCurrAmount = dblCurrAmount - (dblAmount + dblDiscount)
'                    Exit Do
'                End If
'                recTmp.MoveNext
'            Loop
'            If recTmp.EOF And dblCurrAmount > 0 Then
'                dblDiscRate = PayDiscountRate(strDate, lngItemID)
'                dblAmount = dblCurrAmount * dblDiscRate
'                dblDiscount = dblCurrAmount - dblAmount
'                dblPayAmount = dblPayAmount + dblAmount
'                dblPayDiscount = dblPayDiscount + dblDiscount
'                dblCurrAmount = 0
'            End If
'            If dblNoDiscCurrAmount > 0 Then
'                Do While Not recTmp.EOF
'                    dblTmp = UsedAmount(DiscInfosOther, C2lng(recTmp!strTabID), recTmp!lngActivityDetailID)
'                    dblTmp = (recTmp!dblCurRestAmount + recTmp!dblCurrDiscount - dblTmp) / (recTmp!dblCurRestAmount + recTmp!dblCurrDiscount)
'                    If dblNoDiscCurrAmount > recTmp!dblCurRestAmount * dblTmp Then
'                        dblAmount = recTmp!dblCurRestAmount * dblTmp
'                        dblPayAmount = dblPayAmount + recTmp!dblCurRestAmount * dblTmp
'                        dblNoDiscCurrAmount = dblNoDiscCurrAmount - dblAmount
'                    Else
'                        dblAmount = dblNoDiscCurrAmount
'                        dblPayAmount = dblPayAmount + dblAmount
'                        dblNoDiscCurrAmount = dblNoDiscCurrAmount - dblAmount
'                        Exit Do
'                    End If
'                    recTmp.MoveNext
'                Loop
'            End If
'            If dblNoDiscCurrAmount > 0 Then
'                dblPayAmount = dblPayAmount + dblNoDiscCurrAmount
'                dblNoDiscCurrAmount = 0
'            End If
'        Else
'            dblPayAmount = dblCurrAmount
'            dblPayDiscount = 0
'        End If
'    Else
'        dblPayAmount = dblCurrAmount
'        dblPayDiscount = 0
'    End If
'    recCustomer.Close
'    Set recCustomer = Nothing
'    Set recItem = Nothing
'    Set recTmp = Nothing
'    DiscountPayment = True
'    Erase DiscInfos
'    Erase DiscInfosOther
'
'    Exit Function
'
'ErrHandle:
'    Set recCustomer = Nothing
'    Set recItem = Nothing
'    Set recTmp = Nothing
'    DiscountPayment = False
'    Erase DiscInfos
'    Erase DiscInfosOther
'End Function

Public Function DiscountPayment(ByVal lngCustomerID As Long, ByVal strDate As String, ByVal lngItemID As Long, _
    dblPayAmount As Double, dblPayDiscount As Double) As Boolean
'此过程仅计算本期贴息
    Dim strSQL As String
    Dim recTmp As rdoResultset
    
    dblPayDiscount = 0
    strSQL = "SELECT blnIsPayDiscount FROM Customer WHERE lngCustomerID=" & lngCustomerID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenForwardOnly)
    If recTmp.BOF And recTmp.EOF Then
        GoTo EndProc
    End If
    If recTmp(0) = 0 Then GoTo EndProc
    recTmp.Close
    Set recTmp = Nothing
    
    dblPayDiscount = dblPayAmount * (1 - PayDiscountRate(strDate, lngItemID))
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
End Function