clsstocktaking.cls

金算盘软件代码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsStockTaking"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'蔡奇科

'返回 -1：出错  0：取消操作（包括：不能删除，用户取消删除）  1：成功

Option Explicit

Private lngActivityID     As Long       '单据业务ID
Private lngActivityTypeID As Long    '业务类型ID
Private strTypeName       As String   '业务类型名称
Private blnIsVoid         As Boolean  '是否作废
Private thehWnd           As Long     '列表窗体的句柄
Private strDelOrVoid      As String   '提示信息：“删除！” 或 “作废”

'为对话框提供窗口句柄
Public Sub SethWnd(arghWnd As Long)
    thehWnd = arghWnd
End Sub

Private Sub cMsgBox(strMsg As String, Optional strTitle As String)
    If Trim(strTitle) = "" Then
        strTitle = "提示信息"
    End If
    ShowMsg thehWnd, strMsg, MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL, strTitle
End Sub

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

'删除所有的对照表
Private Function DeleteObtendTables() As Integer
'On Error GoTo theErr
    Dim strSql As String
    Dim intResult As Integer
    '1) 删除货位批次明细表
    If lngActivityTypeID = 1 Or lngActivityTypeID = 3 Or lngActivityTypeID = 5 Or lngActivityTypeID = 8 Or lngActivityTypeID = 9 Or lngActivityTypeID = 10 Then
        '商品采购、受托入库、加工入库、自制入库、盘赢、其他入库
        intResult = DeletePositionItemDetail()
        If intResult = -1 Then GoTo TheErr
        If intResult = 0 Then
            DeleteObtendTables = 0
            Exit Function
        End If
    End If
    
    If lngActivityTypeID = 1 Or lngActivityTypeID = 2 Or lngActivityTypeID = 3 Then
        If ChangeItemInfo() = -1 Then GoTo TheErr
    End If
    
    If DeleteItemCostDetail() = -1 Then GoTo TheErr
    
    DeleteObtendTables = 1
    Exit Function
TheErr:
    DeleteObtendTables = -1
End Function

'删除所有的对照表
Private Function DeleteObtendTables_OUT() As Integer
    Dim strSql As String
    Dim intResult As Integer
    On Error GoTo TheErr
    '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 = 11 Or lngActivityTypeID = 13 Or lngActivityTypeID = 16 Then
        '商品销售、委托出库、分期出库
        If ChangeItemInfo_Out() = -1 Then GoTo TheErr
    End If
  
    '删除成本明细表
    If DeleteItemCostDetail() = -1 Then GoTo TheErr
    
    DeleteObtendTables_OUT = 1
    Exit Function
TheErr:
    DeleteObtendTables_OUT = -1
End Function
'改变Item中的 最近销售单据子表ID、最高销售价格单据子表ID、最低销售价格单据子表ID、最近销售价格、最高销售价格、最底销售价格
Private Function ChangeItemInfo_Out() 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
                    dblTempPrice = recTemp_1(0)
                    Set recTemp_1 = Nothing
'                    .rdoColumns(3) = lngTempID
'                    .rdoColumns(6) = dblTempPrice      '最近销售价
                    strSql = "UPDATE Item SET"
                    strSql = strSql & " lngRecentSaleReceiptDetailID=" & lngTempID & " , dblRecenetSalePrice=" & dblTempPrice
                    strSql = strSql & " WHERE lngItemID=" & !ModifyID
                    If gclsBase.ExecSQL(strSql) = False Then
                        GoTo TheErr
                    End If
                End If
'                .Update
            End If

            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)=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(4) = 0
'                    .rdoColumns(7) = 0
                    strSql = "UPDATE Item SET"
                    strSql = strSql & " lngMaxSalePriceReceiptDetailID=0 , dblMaxSalePrice=0 "
                    strSql = strSql & " WHERE lngItemID=" & !ModifyID
                    If gclsBase.ExecSQL(strSql) = False Then
                        GoTo TheErr
                    End If
                Else
                    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)=11) AND ((ItemActivityDetail.lngItemID)=" & lngItemID & "))"
                    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 & " lngMaxSalePriceReceiptDetailID=" & recTemp_1(0) & " , dblMaxSalePrice=" & 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)=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(5) = 0
'                    .rdoColumns(8) = 0
                    strSql = "UPDATE Item SET"
                    strSql = strSql & " lngMinSalePriceReceiptDetailID=0 , dblMinSalePrice=0 "
                    strSql = strSql & " WHERE lngItemID=" & !ModifyID
                    If gclsBase.ExecSQL(strSql) = False Then
                        GoTo TheErr
                    End If
                Else
                   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)=11) AND ((ItemActivityDetail.lngItemID)=" & lngItemID & "))"
                    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 & " lngMinSalePriceReceiptDetailID=" & recTemp_1(0) & " , dblMinSalePrice=" & 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

    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_Out = 1
    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_Out = -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.lngInActivityDetailID 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.lngInActivityDetailID = 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