clssales.cls

金算盘软件代码

'    intResult = DeleteRelation(lngActivityID)
'    If intResult = 0 Then Exit Function
'    If intResult = -1 Then GoTo theErr
EndProc:
    BeforeDelete = 1
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    Exit Function
TheErr:
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    BeforeDelete = -1
End Function

'//////////////////////////////////////////////////////////////////////////////////////////
'
'                                           对照表处理
'
'//////////////////////////////////////////////////////////////////////////////////////////

'删除所有的对照表
Private Function DeleteObtendTables() As Integer
    Dim strSQL As String
    Dim intResult As Integer
    On Error GoTo TheErr
    '删除发票对照表
    If ClearInvoiceObtend() = False Then
        GoTo TheErr
    End If
    '1) 删除货位批次明细表
    If lngActivityTypeID = 11 Or lngActivityTypeID = 13 Or lngActivityTypeID = 15 Or lngActivityTypeID = 16 Or lngActivityTypeID = 19 Or lngActivityTypeID = 21 Or lngActivityTypeID = 22 Then
        '商品销售、委托出库、加工、分期、领用、盘亏、其他
        If ModifyPositionWhenDeleteOutBill(lngActivityID) = False Then GoTo TheErr
    End If
    '加工出库
    If lngActivityTypeID = 15 Then
        intResult = DeleteEntrustInToOut
        If intResult = 0 Then
            DeleteObtendTables = 0
            Exit Function
        End If
        If intResult = -1 Then GoTo TheErr
    End If
    '盘亏出库
    '如果明细可能来自《商品销售订单》
'    If lngActivityTypeID = 11 Or lngActivityTypeID = 13 Or lngActivityTypeID = 16 Then
'        '商品销售、委托出库、分期出库
'        If ChangeItemInfo() = -1 Then GoTo TheErr
'
'        '改变订单的数量, 清除关闭标志
  
    '删除成本明细表
    If DeleteItemCostDetail() = -1 Then GoTo TheErr
    If blnIsReceive Then
        If mblnIsCash Then
            If mdlAccount.DeleteCash(lngActivityID, thehWnd, lngActivityTypeID + 2, strSQL) = False Then
                mstrErrMsg = strSQL
                GoTo TheErr
            End If
        End If
        If blnDeleteCashToArap(lngActivityID, 2, False) = False Then
            GoTo TheErr
        End If

    End If
    If SetStockTakingPost() = False Then GoTo TheErr
    DeleteObtendTables = 1
    Exit Function
TheErr:
    DeleteObtendTables = -1
End Function


'算法：除《调拨》外，对照表的“出”操作为改一条，加一条。《调拨》的“出”操作为改一条加二条
'判断“入”操作是否对应有“出”操作的算法：如果“入”操作对应ID号只有一条记录，则表示无“出”

'货位商品批次明细表
Private Function DeletePositionItemDetail() As Integer
    Dim strSQL As String
'    Dim recTmp As rdoResultset
    
    On Error GoTo DeleteErr
    strSQL = "DELETE FROM PositionItemDetail WHERE PositionItemDetail.lngOutActivityDetailID IN " & _
        " (SELECT ItemActivityDetail.lngActivityDetailID FROM ItemActivityDetail " & _
        " WHERE ItemActivityDetail.lngActivityID=" & lngActivityID & ")"
    If gclsBase.ExecSQL(strSQL) = False Then GoTo DeleteErr
'    strSql = " SELECT PositionItemDetail.lngItemID,PositionItemDetail.lngPositionID,PositionItemDetail.lngInActivityDetailID," _
'           & " PositionItemDetail.lngOutActivityDetailID,PositionItemDetail.dblQuantity " _
'           & " FROM PositionItemDetail,ItemActivityDetail WHERE PositionItemDetail.lngOutActivityDetailID = ItemActivityDetail.lngActivityDetailID " _
'           & " AND (((ItemActivityDetail.lngActivityID)=" & lngActivityID & "))"
'    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'    Do While Not recTmp.EOF
'      strSql = "DELETE PositionItemDetail WHERE lngItemID=" & recTmp(0) & _
'         " AND lngPositionID=" & recTmp(1) & " AND lngInActivityDetailID=" & recTmp(2) & _
'         " AND lngOutActivityDetailID=" & recTmp(3) & " AND dblQuantity=" & recTmp(4)
'      If gclsBase.ExecSQL(strSql) = False Then
'         recTmp.Close
'         Set recTmp = Nothing
'         GoTo DeleteErr
'      End If
'      recTmp.MoveNext
'    Loop
'    recTmp.Close
'    Set recTmp = Nothing
    DeletePositionItemDetail = 1
    Exit Function
DeleteErr:
    DeletePositionItemDetail = -1
End Function



'加工入库与加工出库对照表(15 -- <5>)
'说明：先出库后入库(规则：有了入库的出库单不能删除)
Private Function DeleteEntrustInToOut() As Integer
    Dim strSQL As String
    Dim recTemp As rdoResultset
'    Dim recTmp As rdoResultset
    On Error GoTo TheErr
    
    DeleteEntrustInToOut = 0
    strSQL = "SELECT EntrustInToOut.lngOutActivityDetailID FROM EntrustInToOut,ItemActivityDetail WHERE EntrustInToOut.lngOutActivityDetailID = ItemActivityDetail.lngActivityDetailID" _
           & " AND (ItemActivityDetail.lngActivityID)=" & lngActivityID
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If Not recTemp.EOF Then
        Set recTemp = Nothing
        cMsgBox strBillNO & "加工出库单已有入库，不能" & strDelOrVoid
        Exit Function
    End If
    Set recTemp = Nothing
    
    strSQL = "DELETE FROM EntrustInToOut WHERE EntrustInToOut.lngOutActivityDetailID IN " & _
        " (SELECT ItemActivityDetail.lngActivityDetailID FROM ItemActivityDetail " & _
        " WHERE ItemActivityDetail.lngActivityID = " & lngActivityID & ")"
    If gclsBase.ExecSQL(strSQL) = False Then GoTo TheErr
'''    strSql = "SELECT EntrustInToOut.lngInActivityDetailID,EntrustInToOut.lngOutActivityDetailID," _
'''           & "EntrustInToOut.dblQuantity,EntrustInToOut.dblAmount " _
'''           & "FROM EntrustInToOut,ItemActivityDetail WHERE EntrustInToOut.lngOutActivityDetailID = 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 TheErr
'''      End If
'''      recTmp.MoveNext
'''    Loop
'''    recTmp.Close
'''    Set recTmp = Nothing
    DeleteEntrustInToOut = 1
    Exit Function
TheErr:
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    DeleteEntrustInToOut = -1
End Function

'盘点表与盘赢/盘亏单对照表(21)
'如果是盘点表生成的盘亏单，则不能删除该盘亏单
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 lngTempID As Long
    Dim dblTempPrice As Double
    Dim lngItemID As Long
    Dim dblQuantity As Double
    Dim dblCurrPrice_Temp As Double
    On Error GoTo TheErr
    
    strSQL = "SELECT ItemActivityDetail.lngActivityDetailID, ItemActivityDetail.lngItemID, ItemActivityDetail.dblQuantity, " _
           & " Item.lngRecentSaleReceiptDetailID, " _
           & " Item.lngMaxSalePriceReceiptDetailID, " _
           & " Item.lngMinSalePriceReceiptDetailID, " _
           & " Item.dblRecenetSalePrice, " _
           & " Item.dblMaxSalePrice, " _
           & " Item.dblMinSalePrice,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 & "单据中的商品，删除失败！"
        Set recTemp = Nothing
        Exit Function
    End If
    With recTemp
        .MoveFirst
        Do While Not .EOF
            lngActivityDetailID = .rdoColumns(0)
            lngItemID = .rdoColumns(1)
            dblQuantity = .rdoColumns(2)
            
            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)=11) 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 & " lngRecentSaleReceiptDetailID=0 , dblRecenetSalePrice=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