discount.bas

金算盘软件代码

Private Function PayDiscountRate(ByVal strDate As String, ByVal lngItemID As Long) As Double
    Dim strSQL As String
    Dim recDetail As rdoResultset
    
    strSQL = "SELECT dblDiscountRate FROM ItemPayDiscDate , ItemPayDiscDetail " _
        & "WHERE ItemPayDiscDate.lngItemPayDiscID=ItemPayDiscDetail.lngItemPayDiscID " _
        & "AND ' '||Ltrim(strStartDate)<=' " & LTrim(strDate) & "' AND ' '||Ltrim(strEndDate)>=' " & LTrim(strDate) & "' " _
        & "AND lngItemID=" & lngItemID
    Set recDetail = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If Not recDetail.EOF Then
        PayDiscountRate = recDetail!dblDiscountRate / 100
    Else
        PayDiscountRate = 1
    End If
    recDetail.Close
    Set recDetail = Nothing
End Function

'计算商品业务应当享受的折扣率
'入口参数：
'lngCustomerID      单位ID
'lngItemID          商品ID
'strDate            业务发生日期
'lngCurrencyID      币种ID
'dblCurrAmount      本币折扣前金额
'dblQuantity        数量
'lngReceiptTypeID   单据类型ID
'bytCalcMethod      计算方式，(1+2+4+8+16,1 商品折扣,2 贴息折扣,4 批量折扣,8 促销折扣,16 客户折扣)
Public Function CalcDiscountRate(ByVal lngCustomerID As Long, ByVal lngItemID As Long, ByVal strDate As String, _
    ByVal lngCurrencyID As Long, ByVal dblAmount As Double, ByVal dblQuantity As Double, _
    ByVal lngReceiptTypeID As Long, Optional ByVal blnBeforePayDisc As Boolean = False, _
    Optional ByVal bytCalcMethod As Byte = 31) As Double
    
    Dim strSQL As String
    Dim recTmp As rdoResultset
    Dim bytOrder() As Byte
    Dim i As Integer
    Dim dblDiscAmount As Double
    Dim dblTmp1 As Double
    Dim dblTmp2 As Double
    Dim dblNoDiscAmount As Double
    
    CalcDiscountRate = 0
    If bytCalcMethod = 31 Then
        Select Case lngReceiptTypeID
        Case 1 To 5
            bytCalcMethod = 16
        Case 12, 13, 14
        Case 15, 18
            bytCalcMethod = 29
'        Case 16, 19
'            bytCalcMethod = 12
        Case Else
            Erase bytOrder
            Exit Function
        End Select
    End If
    
    GetDiscOrder bytOrder(), lngReceiptTypeID
    
    strSQL = "SELECT dblNoDiscAmount1 FROM Item WHERE lngItemID = " & lngItemID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenForwardOnly)
    If recTmp.BOF And recTmp.EOF Then
        recTmp.Close
        Set recTmp = Nothing
        Erase bytOrder
        Exit Function
    End If
    dblNoDiscAmount = recTmp!dblNoDiscAmount1 * dblQuantity
    
    dblAmount = dblAmount - dblNoDiscAmount
    
    For i = 0 To 4
        Select Case bytOrder(i)
        Case 1  '商品折扣
            If (bytCalcMethod And 1) <> 0 Then
                DiscountItem lngItemID, dblAmount - dblDiscAmount, dblTmp1, dblTmp2
                dblDiscAmount = dblDiscAmount + dblTmp2
            End If
        Case 2  '贴息折扣
            If blnBeforePayDisc Then
                Exit For
            End If
            If (bytCalcMethod And 2) <> 0 Then
                DiscountPayment lngCustomerID, strDate, lngItemID, dblAmount - dblDiscAmount, dblTmp2
                dblDiscAmount = dblDiscAmount + dblTmp2
            End If
        Case 3  '批量折扣
            If (bytCalcMethod And 4) <> 0 Then
                dblTmp1 = dblNoDiscAmount
                DiscountBatch lngItemID, dblQuantity, dblAmount - dblDiscAmount, dblTmp1, dblTmp2
                dblDiscAmount = dblDiscAmount + dblTmp2
            End If
        Case 4  '促销折扣
            If (bytCalcMethod And 1) <> 8 Then
                DiscountSale lngItemID, strDate, dblAmount - dblDiscAmount, dblTmp1, dblTmp2
                dblDiscAmount = dblDiscAmount + dblTmp2
            End If
        Case 5  '客户折扣
            If (bytCalcMethod And 1) <> 16 Then
                DiscountCustomer lngCustomerID, dblAmount - dblDiscAmount, dblTmp1, dblTmp2
                dblDiscAmount = dblDiscAmount + dblTmp2
            End If
        End Select
    Next
    CalcDiscountRate = dblDiscAmount / (dblAmount + dblNoDiscAmount)
    Erase bytOrder
End Function

Public Function GetDiscOrder(ByRef bytOrder() As Byte, ByVal lngReceiptTypeID As Long)
    '确定折扣计算顺序
    Dim strSQL As String
    Dim recTmp As rdoResultset
    Dim i As Integer
    ReDim bytOrder(5)
    
    strSQL = "SELECT * FROM Setting WHERE lngModuleID=7 AND (strSection='折扣顺序' OR strSection='折扣启用') ORDER BY strKey,strSetting"
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    With recTmp
        If .BOF And .EOF Then
            .Close
            Set recTmp = Nothing
            Exit Function
        Else
            Do While Not .EOF
                i = C2lng(!strSetting) - 1
                Select Case !strKey
                Case "商品折扣"
                    bytOrder(i) = 1
                Case "贴息折扣"
                    If lngReceiptTypeID = 12 Or lngReceiptTypeID = 13 Or lngReceiptTypeID = 14 Or lngReceiptTypeID = 0 Then   '仅销售单享受贴息折扣
                        bytOrder(i) = 2
                    Else
                        bytOrder(i) = 0
                    End If
                Case "批量折扣"
                    bytOrder(i) = 3
                Case "促销折扣"
                    bytOrder(i) = 4
                Case "客户折扣"
                    bytOrder(i) = 5
                End Select
                .MoveNext
                If UCase(!strSetting) <> "TRUE" Then
                    bytOrder(i) = 0
                End If
                .MoveNext
            Loop
        End If
        .Close
        Set recTmp = Nothing
    End With
End Function

Public Sub RemoveADiscInfo(ColDiscInfos As Collection, ByVal lngRowno As Long)
    Dim i As Long
    Dim j As Integer
    
    For i = ColDiscInfos.Count - 6 To 1 Step -7
        If ColDiscInfos.Item(i) = lngRowno Then
            If ColDiscInfos.Item(i + 4) <> 0 Then
                ColDiscInfos.Add 0, , i
                ColDiscInfos.Remove i + 1
                ColDiscInfos.Add 0, , i + 3
                ColDiscInfos.Remove i + 4

'                ColDiscInfos.Item(i) = 0
'                ColDiscInfos.Item(i + 3) = 0
            Else
                For j = 6 To 0 Step -1
                    ColDiscInfos.Remove i + j
                Next
            End If
        End If
    Next
End Sub

Public Sub AddADiscInfo(ColDiscInfos As Collection, ByVal lngRowno As Long, ByVal lngTableID As Long, _
    ByVal lngActivityDetailID As Long, ByVal dblUsedAmount As Double, ByVal dblSavedAmount As Double, _
    ByVal dblDiscountRate As Double, ByVal strDate As String)
    ColDiscInfos.Add Val(lngRowno)
    ColDiscInfos.Add Val(lngTableID)
    ColDiscInfos.Add Val(lngActivityDetailID)
    ColDiscInfos.Add Val(dblUsedAmount)
    ColDiscInfos.Add Val(dblSavedAmount)
    ColDiscInfos.Add Val(dblDiscountRate)
    ColDiscInfos.Add Format(C2Date(strDate), "yyyy-mm-dd")
End Sub

Public Sub AdjustDiscInfoRowNO(ColDiscInfos As Collection, ByVal lngRowno As Long, ByVal blnInsOrDel As Boolean)
    Dim i As Long
    
    For i = ColDiscInfos.Count - 6 To 1 Step -7
        If ColDiscInfos.Item(i) >= lngRowno Then
            If blnInsOrDel Then
                ColDiscInfos.Add Val(ColDiscInfos.Item(i) + 1), , i
                ColDiscInfos.Remove i + 1
            Else
                ColDiscInfos.Add Val(ColDiscInfos.Item(i) - 1), , i
                ColDiscInfos.Remove i + 1
            End If
        End If
    Next
End Sub

Public Sub ClearDiscInfo(ColDiscInfos As Collection)
    Do While ColDiscInfos.Count > 0
        ColDiscInfos.Remove 1
    Loop
End Sub

Public Function ModifyOutStockQuantity(ByVal lnghWnd As Long, ByVal lngID As Long, _
    Optional ByVal blnAddOrDel As Boolean = True) As Boolean
    ModifyOutStockQuantity = True
    Exit Function

'#If conQuanDisc = -1 Then
    
    Dim strSQL As String
    Dim recTmp As rdoResultset
    Dim recTmp2 As rdoResultset

    ModifyOutStockQuantity = False
    
    strSQL = "SELECT blnisvoid,lngReceipttypeid from ItemActivity where lngActivityID=" & lngID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenForwardOnly)
    If recTmp.BOF And recTmp.EOF Then
        recTmp.Close
        Set recTmp = Nothing
        Exit Function
    End If
    If recTmp(0) <> 0 Then
        ModifyOutStockQuantity = True
        recTmp.Close
        Set recTmp = Nothing
        Exit Function
    End If
    
    If recTmp(1) <> 13 Then
        ModifyOutStockQuantity = True
        recTmp.Close
        Set recTmp = Nothing
        Exit Function
    End If
    
    If blnAddOrDel = False Then
        strSQL = "SELECT dblQuantity,lngItemID FROM ItemActivityDetail WHERE lngPositionID=-100 AND lngActivityID=" & lngID
        Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
        Do While Not recTmp.EOF
            strSQL = "Update Item SET dblOuterQuantity=dblOuterQuantity+" & recTmp!dblQuantity _
                & " WHERE lngItemID=" & recTmp!lngItemID
            If Not gclsBase.ExecSQL(strSQL) Then
                recTmp.Close
                Set recTmp = Nothing
                Exit Function
            End If
            recTmp.MoveNext
        Loop
        recTmp.Close
        Set recTmp = Nothing
    Else
        strSQL = "SELECT dblQuantity,lngItemID,lngRowID FROM ItemActivityDetail WHERE lngPositionID=-100 AND lngActivityID=" & lngID
        Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
        Do While Not recTmp.EOF
            strSQL = "SELECT dblOuterQuantity FROM Item WHERE lngItemID=" & recTmp!lngItemID
            Set recTmp2 = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenDynamic, rdConcurValues)
                If recTmp2.BOF And recTmp2.EOF Then
                    recTmp2.Close
                    Set recTmp2 = Nothing
                    recTmp.Close
                    Set recTmp = Nothing
                    Exit Function
                End If
                If recTmp2(0) < recTmp!dblQuantity Then
                    If lnghWnd <> 0 Then
                        ShowMsg lnghWnd, "第" & recTmp!lngRowID & "的数量超过外库数量，不能存盘！", MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL, "修改单据"
                    End If
                    recTmp2.Close
                    Set recTmp2 = Nothing
                    recTmp.Close
                    Set recTmp = Nothing
                    Exit Function
                End If
                recTmp2.Edit
                    recTmp2(0) = recTmp2(0) - recTmp!dblQuantity
                recTmp2.Update
                recTmp2.Close
            recTmp.MoveNext
        Loop
        recTmp.Close
        Set recTmp2 = Nothing
        Set recTmp = Nothing
    End If
    ModifyOutStockQuantity = True
'#Else
'    ModifyOutStockQuantity = True
'#End If
End Function

Public Function blnIsInvoice(ByVal blnPurchase As Boolean, _
    Optional ByVal lngActivityID As Long = 0, Optional ByVal lngActivityDetailID As Long = 0) As Boolean
    '判断单据、明细是否已开票，5.31版
    'lngActivityID>0时判断单据
    'lngActivityDetailID>0时判断明细
    
    Dim strSQL As String
    Dim recTmp As rdoResultset
    
    blnIsInvoice = False
    If lngActivityID > 0 Then
        If blnPurchase Then
            strSQL = "SELECT PurchaseToInvoice.lngInvoiceDetailID  FROM ItemActivity,ItemActivityDetail,PurchaseToInvoice " & _
                " WHERE ROWNUM<=1 AND ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID " & _
                " AND ItemActivityDetail.lngActivityDetailID = PurchaseToInvoice.lngReceiptDetialID " & _
                " AND ItemActivity.lngActivityID = " & lngActivityID
        Else
            strSQL = "SELECT SaleToInvoice.lngInvoiceDetailID FROM ItemActivity,ItemActivityDetail,SaleToInvoice " & _
                " WHERE ROWNUM<=1 AND ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID " & _
                " AND ItemActivityDetail.lngActivityDetailID = SaleToInvoice.lngReceiptDetialID " & _
                " AND ItemActivity.lngActivityID = " & lngActivityID
        End If
    ElseIf lngActivityDetailID > 0 Then
        If blnPurchase Then
            strSQL = "SELECT PurchaseToInvoice.lngInvoiceDetailID FROM ItemActivityDetail,PurchaseToInvoice " & _
                " WHERE ROWNUM<=1 AND ItemActivityDetail.lngActivityDetailID = PurchaseToInvoice.lngReceiptDetialID " & _
                " AND ItemActivityDetail.lngActivityDetailID = " & lngActivityDetailID
        Else
            strSQL = "SELECT SaleToInvoice.lngInvoiceDetailID FROM ItemActivityDetail,SaleToInvoice " & _
                " WHERE ROWNUM<=1 ItemActivityDetail.lngActivityDetailID = SaleToInvoice.lngReceiptDetialID " & _
                " AND ItemActivityDetail.lngActivityDetailID = " & lngActivityDetailID
        End If
    Else
        GoTo EndProc
    End If
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenForwardOnly)
    If Not (recTmp.BOF And recTmp.EOF) Then
        blnIsInvoice = True
    End If
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
End Function