clspurchase.cls

金算盘软件代码

'加工入库与加工出库对照表（5 -- 15）
'说明：先出库后入库(规则：有了入库的出库单不能删除)
'删除加工入库单，不必进行规则检查
Private Function DeleteEntrustInToOut() As Integer
    Dim strSQL As String
    Dim recTmp As rdoResultset
    strSQL = "SELECT  detaildel.dblEntrustQuantity, detaildel.dblEntrustAmount,EntrustInToOut.*,detaildel.lngActivityDetailID AS ModifyID " & _
                " FROM EntrustInToOut,ItemActivityDetail,ItemActivityDetail DetailDel " & _
                " WHERE EntrustInToOut.lngInActivityDetailID = ItemActivityDetail.lngActivityDetailID " & _
                " AND EntrustInToOut.lngOutActivityDetailID = DetailDel.lngActivityDetailID " & _
                " AND (((ItemActivityDetail.lngActivityID)=" & lngActivityID & "))"
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    Do While Not recTmp.EOF
'        recTmp.Edit
        strSQL = "UPDATE ItemActivityDetail SET "
'        recTmp.rdoColumns(0) = recTmp.rdoColumns(0) - recTmp!dblQuantity
'        recTmp!dblEntrustAmount = recTmp!dblEntrustAmount - recTmp!dblAmount
         strSQL = strSQL & " dblEntrustQuantity=dblEntrustQuantity-" & recTmp!dblQuantity
         strSQL = strSQL & " , dblEntrustAmount=dblEntrustAmount-" & recTmp!dblAmount
         strSQL = strSQL & " WHERE lngActivityDetailID=" & recTmp!ModifyID
         If gclsBase.ExecSQL(strSQL) = False Then
            GoTo DeleteErr
         End If
'        recTmp.Update
        recTmp.MoveNext
    Loop
    recTmp.Close
    Set recTmp = Nothing
    strSQL = "DELETE FROM EntrustInToOut WHERE EntrustInToOut.lngInActivityDetailID IN " & _
        " (SELECT ItemActivityDetail.lngActivityDetailID FROM ItemActivityDetail " & _
        " WHERE ItemActivityDetail.lngActivityID=" & lngActivityID & ")"
    If gclsBase.ExecSQL(strSQL) = False Then GoTo DeleteErr
'''    strSql = "SELECT EntrustInToOut.lngInActivityDetailID,EntrustInToOut.lngOutActivityDetailID," _
'''           & "EntrustInToOut.dblQuantity,EntrustInToOut.dblAmount " _
'''           & "FROM EntrustInToOut,ItemActivityDetail WHERE EntrustInToOut.lngInActivityDetailID = ItemActivityDetail.lngActivityDetailID " _
'''           & " AND (((ItemActivityDetail.lngActivityID)=" & lngActivityID & "))"
'''    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'''    Do While Not recTmp.EOF
'''      strSql = "DELETE EntrustInToOut WHERE lngInActivityDetailID=" & recTmp(0) _
'''         & " AND lngOutActivityDetailID=" & recTmp(1) & " AND lngOutActivityDetailID=" & recTmp(2) & " AND dblAmount=" & recTmp(3)
'''      If gclsBase.ExecSQL(strSql) = False Then
'''         recTmp.Close
'''         Set recTmp = Nothing
'''         GoTo DeleteErr
'''      End If
'''      recTmp.MoveNext
'''    Loop
'''    recTmp.Close
'''    Set recTmp = Nothing
    DeleteEntrustInToOut = 1
    Exit Function
DeleteErr:
    If Not recTmp Is Nothing Then
        Set recTmp = Nothing
    End If
    DeleteEntrustInToOut = -1
End Function

'盘点表与盘赢/盘亏单对照表(9)
'如果是盘点表生成的盘盈单，则不能删除该盘盈单
Private Function DeleteStockTakingToReceipt() As Integer
    Dim strSQL As String
    Dim recTemp As rdoResultset
    Dim intCount As Integer
    On Error GoTo DeleteErr
    strSQL = " SELECT ItemActivityDetail.lngActivityDetailID FROM ItemActivityDetail " & _
                  " WHERE (ItemActivityDetail.lngActivityID)=" & lngActivityID & " AND ItemActivityDetail.lngOrderDetailID<>0 "
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    
    If Not (recTemp.BOF And recTemp.EOF) Then
'        cMsgBox strBillNO & "盘盈单是由盘点表产生，不能删除、作废！"
        DeleteStockTakingToReceipt = 0
    Else
        DeleteStockTakingToReceipt = 1
    End If
    Set recTemp = Nothing
    Exit Function
DeleteErr:
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    DeleteStockTakingToReceipt = -1
    
End Function

'改变Item中的 最近采购单据子表ID、最高采购价格单据子表ID、最低采购价格单据子表ID、最近采购价格、最高采购价格、最底采购价格
Private Function ChangeItemInfo() As Integer
    Dim strSQL As String
    Dim recTemp As rdoResultset
    Dim recTemp_1 As rdoResultset
    Dim lngActivityDetailID As Long
    Dim lngItemID As Long
    Dim lngTempID As Long
    Dim dblTempPrice As Double
    Dim dblQuantity As Double
    Dim lngPositionID As Long
    Dim dblCurrPrice_Temp As Double
    On Error GoTo TheErr

    strSQL = "SELECT ItemActivityDetail.lngActivityDetailID, ItemActivityDetail.lngItemID, ItemActivityDetail.dblQuantity, " _
           & " Item.lngRecentPurchaseDetailID," _
           & " Item.lngMaxPurchasePriceDetailID," _
           & " Item.lngMinPurchasePriceDetailID," _
           & " Item.dblRecenetPurchasePrice," _
           & " Item.dblMaxPurchasePrice," _
           & " Item.dblMinPurchasePrice,Item.lngItemID AS ModifyID" _
           & " FROM Item ,ItemActivityDetail where Item.lngItemID = ItemActivityDetail.lngItemID" _
           & " AND (((ItemActivityDetail.lngActivityID)=" & lngActivityID & ")) ORDER BY ItemActivityDetail.lngItemID "
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If recTemp.BOF And recTemp.EOF Then
        cMsgBox "不能从数据库中找到" & strBillNO & strTypeName & "单据中的商品，删除失败！"
        Exit Function
    End If
    With recTemp
        .MoveFirst
        Do While Not .EOF
            lngActivityDetailID = .rdoColumns(0)
            lngItemID = .rdoColumns(1)
            dblQuantity = .rdoColumns(2)
            
            '1)
            If .rdoColumns(0) = .rdoColumns(3) Then '当前ID是最近采购单据子表ID
                strSQL = "SELECT Max(ItemActivityDetail.lngActivityDetailID) AS 表达式1" _
                       & " FROM ItemActivity , ItemActivityDetail WHERE ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID" _
                       & " AND (((ItemActivity.lngActivityTypeID)=1) AND ((ItemActivityDetail.lngItemID)=" & lngItemID & ") AND ((ItemActivityDetail.lngActivityDetailID)<>" & lngActivityDetailID & "))"
                Set recTemp_1 = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
'                .Edit
                If (recTemp_1.BOF And recTemp_1.EOF) Or (IsNull(recTemp_1(0))) Then
                     
'                    .rdoColumns(3) = 0
'                    .rdoColumns(6) = 0
                     strSQL = "UPDATE Item SET "
                     strSQL = strSQL & " lngRecentPurchaseDetailID=0 , dblRecenetPurchasePrice=0 "
                     strSQL = strSQL & " WHERE lngItemID=" & !ModifyID
                     If gclsBase.ExecSQL(strSQL) = False Then
                        GoTo TheErr
                     End If
                Else
                    lngTempID = recTemp_1(0) '新的最近采购单据子表ID
                    Set recTemp_1 = Nothing
                    strSQL = "SELECT ItemActivityDetail.dblCurrPrice From ItemActivityDetail WHERE (ItemActivityDetail.lngActivityDetailID)=" & lngTempID
                    Set recTemp_1 = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
                    If recTemp_1.BOF And recTemp_1.EOF Then Exit Function
                    
'                    .rdoColumns(3) = lngTempID
'                    .rdoColumns(6) = recTemp_1(0)     '最近采购价
                    strSQL = "UPDATE Item SET "
                    strSQL = strSQL & " lngRecentPurchaseDetailID=" & lngTempID & " , dblRecenetPurchasePrice=" & recTemp_1(0)
                    strSQL = strSQL & " WHERE lngItemID=" & !ModifyID
                    Set recTemp_1 = Nothing
                     If gclsBase.ExecSQL(strSQL) = False Then
                        GoTo TheErr
                     End If
                End If
'                .Update
            End If
            '2)
            If .rdoColumns(0) = .rdoColumns(4) Then '当前ID是最高采购价格单据子表ID
                strSQL = "SELECT Max(ItemActivityDetail.dblCurrPrice) AS 表达式1" _
                       & " FROM ItemActivity , ItemActivityDetail WHERE ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID" _
                       & " AND (((ItemActivity.lngActivityTypeID)=1) AND ((ItemActivityDetail.lngItemID)=" & lngItemID & ") AND ((ItemActivityDetail.lngActivityDetailID)<>" & lngActivityDetailID & "))"
                Set recTemp_1 = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
'                .Edit
                If (recTemp_1.BOF And recTemp_1.EOF) Or (IsNull(recTemp_1(0))) Then
'                    .rdoColumns(4) = 0
'                    .rdoColumns(7) = 0
                     strSQL = "UPDATE Item SET "
                     strSQL = strSQL & " lngMaxPurchaseDetailID=0 , dblMaxPurchasePrice=0 "
                     strSQL = strSQL & " WHERE lngItemID=" & !ModifyID
                     If gclsBase.ExecSQL(strSQL) = False Then
                        GoTo TheErr
                     End If
                Else
                    '通过最高价查找ID
                    dblCurrPrice_Temp = recTemp_1(0)
                    Set recTemp_1 = Nothing
                    strSQL = "SELECT ItemActivityDetail.lngActivityDetailID " _
                           & " FROM ItemActivity , ItemActivityDetail WHERE ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID " _
                           & " AND (((ItemActivityDetail.dblCurrPrice)=" & dblCurrPrice_Temp & ") AND ((ItemActivity.lngActivityTypeID)=1) AND ((ItemActivityDetail.lngItemID)=" & lngItemID & ") AND ((ItemActivityDetail.lngActivityDetailID)<>36))"
                    Set recTemp_1 = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
                    If recTemp_1.BOF And recTemp.EOF Then Exit Function
                    
'                    .rdoColumns(4) = recTemp_1(0)
'                    .rdoColumns(7) = dblCurrPrice_Temp
                    strSQL = "UPDATE Item SET "
                    strSQL = strSQL & " lngMaxPurchaseDetailID=" & recTemp_1(0) & " , dblMaxPurchasePrice=" & dblCurrPrice_Temp
                    strSQL = strSQL & " WHERE lngItemID=" & !ModifyID
                    Set recTemp_1 = Nothing
                     If gclsBase.ExecSQL(strSQL) = False Then
                        GoTo TheErr
                     End If
                End If
'                .Update
            End If
            '3)
            If .rdoColumns(0) = .rdoColumns(5) Then '当前ID是最低采购价格单据子表ID
                strSQL = "SELECT Min(ItemActivityDetail.dblCurrPrice) AS 表达式1" _
                       & " FROM ItemActivity,ItemActivityDetail WHERE ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID" _
                       & " AND (((ItemActivity.lngActivityTypeID)=1) AND ((ItemActivityDetail.lngItemID)=" & lngItemID & ") AND ((ItemActivityDetail.lngActivityDetailID)<>" & lngActivityDetailID & "))"
                Set recTemp_1 = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
'                .Edit
                If (recTemp_1.BOF And recTemp_1.EOF) Or (IsNull(recTemp_1(0))) Then
'                    .rdoColumns(5) = 0
'                    .rdoColumns(8) = 0
                     strSQL = "UPDATE Item SET "
                     strSQL = strSQL & " lngMinPurchaseDetailID=0 , dblMinPurchasePrice=0 "
                     strSQL = strSQL & " WHERE lngItemID=" & !ModifyID
                     If gclsBase.ExecSQL(strSQL) = False Then
                        GoTo TheErr
                     End If
                Else
                    '通过最低价查找ID
                    dblCurrPrice_Temp = recTemp_1(0)
                    Set recTemp_1 = Nothing
                    strSQL = "SELECT ItemActivityDetail.lngActivityDetailID " _
                           & " FROM ItemActivity , ItemActivityDetail WHERE ItemActivity.lngActivityID = ItemActivityDetail.lngActivityID " _
                           & " AND (((ItemActivityDetail.dblCurrPrice)=" & dblCurrPrice_Temp & ") AND ((ItemActivity.lngActivityTypeID)=1) AND ((ItemActivityDetail.lngItemID)=" & lngItemID & ") AND ((ItemActivityDetail.lngActivityDetailID)<>36))"
                    Set recTemp_1 = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
                    If recTemp_1.BOF And recTemp.EOF Then Exit Function
                            
'                    .rdoColumns(5) = recTemp_1(0)
'                    .rdoColumns(8) = dblCurrPrice_Temp
                    strSQL = "UPDATE Item SET "
                    strSQL = strSQL & " lngMinPurchaseDetailID=" & recTemp_1(0) & " , dblMinPurchasePrice=" & dblCurrPrice_Temp
                    strSQL = strSQL & " WHERE lngItemID=" & !ModifyID
                    Set recTemp_1 = Nothing
                     If gclsBase.ExecSQL(strSQL) = False Then
                        GoTo TheErr
                     End If

                End If
'                .Update
            End If
            .MoveNext
        Loop
    End With
    ChangeItemInfo = 1
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    If Not recTemp_1 Is Nothing Then
        Set recTemp_1 = Nothing
    End If
    Exit Function
TheErr:
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    If Not recTemp_1 Is Nothing Then
        Set recTemp_1 = Nothing
    End If
    ChangeItemInfo = -1
End Function


'商品成本资料明细
'商品性质表中存在：成本方法
Private Function DeleteItemCostDetail() As Integer
    Dim strSQL As String
'    Dim recTmp As rdoResultset
    
   DeleteItemCostDetail = 1
    Select Case lngActivityTypeID
        Case 1, 3, 5, 8, 9, 10
            strSQL = "DELETE FROM ItemCostDetail WHERE ItemCostDetail.lngInActivityDetailID IN " & _
                " (SELECT ItemActivityDetail.lngActivityDetailID FROM ItemActivityDetail " & _
                " WHERE ItemActivityDetail.lngActivityID=" & lngActivityID & ")"