clsstartdel.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 = "clsStartDel"
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

'单据删除（作废）前的规则验证
Public Function BeforeDelete(Optional ByVal blnByVoid As Boolean = False, _
                                            Optional ByVal lngReceiptID As Long = 0, _
                                            Optional ByVal lngReceiptTypeID As Long = 0, _
                                            Optional ByVal strReceiptTypeName As String = "") As Integer
    Dim strSQL As String
    Dim recTemp As rdoResultset
    Dim strVoucher As String
    Dim intResult As Integer
    On Error GoTo TheErr
    strDelOrVoid = IIf(blnByVoid, "作废", "删除")
    If lngReceiptID <> 0 Then lngActivityID = lngReceiptID
    If lngReceiptTypeID <> 0 Then lngActivityTypeID = ReceiptType2ActivityType(lngReceiptTypeID)
    If strReceiptTypeName <> "" Then strTypeName = strReceiptTypeName
    
    BeforeDelete = 0 '取消删除
    Select Case IsVoucher_ItemActivity(lngActivityID, strVoucher)
    Case -1
        GoTo TheErr
    Case 1
        cMsgBox "本张" & strTypeName & "单已生成凭证“" & strVoucher & "”，不能" & strDelOrVoid
        Exit Function
    End Select
    If lngActivityTypeID = 41 Then '库存起初
        Select Case IsProduce()
        Case -1
            GoTo TheErr
        Case 1
            cMsgBox "本张" & strTypeName & "单的批次商品已发生出库业务，不能" & strDelOrVoid
            Exit Function
        End Select
    End If
    
    strSQL = "SELECT Sum(abs(dblSettlementQuantity)) AS dblSettlementQuantityOfSum, " _
                 & " Sum(abs(dblCurrSettlementAmount)) AS dblCurrSettlementAmountOfSum, " _
                 & " Sum(abs(dblPaymentQuantity)) AS dblPaymentQuantityOfSum, " _
                 & " Sum(abs(dblCurrPaymentAmount)) AS dblCurrPaymentAmountOfSum, " _
                 & " Sum(abs(dblInvoiceQuantity)) AS dblInvoiceQuantityOfSum, " _
                 & " Sum(abs(dblCurrInvoiceAmount)) AS dblCurrInvoiceAmountOfSum, " _
                 & " Sum(abs(dblEntrustQuantity)) AS dblEntrustQuantityOfSum, " _
                 & " Sum(abs(dblEntrustAmount)) AS dblEntrustAmountOfSum " _
                 & " FROM ItemActivityDetail Where (((ItemActivityDetail.lngActivityID) = " & lngActivityID & ")) GROUP BY ItemActivityDetail.lngActivityID"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If recTemp.BOF And recTemp.EOF Then GoTo TheErr
    '1 采购     与 发票
    '2 销售     与 发票
    '3 直运采购 与 直运销售
    '4 受托入库（源） 与 受托结算  3 -- 4
    '5 委托出库（源） 与 委托结算 13 -- 14
    '6 分期出库（源） 与 分期结算 16 -- 17
    
    If recTemp(4) > 10 ^ (-5) Or recTemp(5) > 10 ^ (-5) Then    '开票数量 原币开票金额
        cMsgBox "本张" & strTypeName & "单已开票，不能" & strDelOrVoid
        Set recTemp = Nothing
        Exit Function
    End If
    If recTemp(6) > 10 ^ (-5) Or recTemp(7) > 10 ^ (-5) Then    '加工数量 原币加工金额
        Select Case lngActivityTypeID
        Case 46
            cMsgBox "本张" & strTypeName & "单已结算，不能" & strDelOrVoid
        Case Else
            cMsgBox "本张" & strTypeName & "单已加工入库，不能" & strDelOrVoid
        End Select
        Set recTemp = Nothing
        Exit Function
    End If

    If recTemp(0) > 10 ^ (-5) Or recTemp(1) > 10 ^ (-5) Then
        '结算数量 原币结算金额 包括：2 直运采购 3 受托入库 13受托出库单 16分期出库单
        Select Case lngActivityTypeID
        Case 45
            cMsgBox "本张直运采购期初单中的商品已经销售，不能" & strDelOrVoid
            Exit Function
        Case Else
            cMsgBox "本张" & strTypeName & "单已进行结算，不能" & strDelOrVoid
        End Select
        Set recTemp = Nothing
        Exit Function
    End If
    
    If recTemp(2) > 10 ^ (-5) Or recTemp(3) > 10 ^ (-5) Then   '付款数量、原币付款金额
            If ShowMsg(thehWnd, "本张" & strTypeName & "单据已付款，继续" & strDelOrVoid & "吗？", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "提示信息") <> IDYES Then Exit Function
    End If
    If lngActivityIsSelected(lngActivityID, strDelOrVoid, thehWnd) <> 0 Then
        Exit Function
    End If
    
    If lngActivityTypeID = 41 Then
        strSQL = "SELECT Item.lngItemID FROM ItemActivityDetail,Item,ItemNature  "
        strSQL = strSQL & " WHERE ItemActivityDetail.lngItemID=Item.lngItemID AND Item.lngItemNatureID=ItemNature.lngItemNatureID"
        strSQL = strSQL & " AND ItemActivityDetail.lngActivityID=" & lngActivityID & " AND Item.strRecentDate<>' '"
        strSQL = strSQL & " AND (ItemNature.strCostMethod='6' OR ItemNature.strCostMethod='7')"
        Set recTemp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenForwardOnly)
        If Not recTemp.EOF Then
            recTemp.Close
            Set recTemp = Nothing
            cMsgBox "本张" & strTypeName & "单中的商品已调价，不能" & strDelOrVoid
            Exit Function
        End If
        recTemp.Close
    End If
    
    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 IsProduce() As Integer
    Dim strSQL As String
    Dim recTemp As rdoResultset
    On Error GoTo TheErr
    
    '判断批次商品有无出库等业务
    strSQL = "SELECT PositionItemDetail.lngInActivityDetailID" _
           & " FROM PositionItemDetail,ItemActivityDetail " _
           & " WHERE PositionItemDetail.lngInActivityDetailID = ItemActivityDetail.lngActivityDetailID AND ItemActivityDetail.lngActivityID=" & lngActivityID & " AND PositionItemDetail.lngOutActivityDetailID<>0" _
           & " AND ( NOT (PositionItemDetail.lngOutActivityDetailID IN (SELECT lngActivityDetailID FROM ItemActivityDetail WHERE lngActivityID=" & lngActivityID & ")))"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If Not recTemp.EOF Then
        IsProduce = 1 '批次商品已发生出库业务
    Else
        IsProduce = 0 '没有发生出库业务
    End If
    Set recTemp = Nothing
    Exit Function
TheErr:
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    IsProduce = -1
End Function


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

'删除所有的对照表
Private Function DeleteObtendTables() As Integer
    On Error GoTo TheErr
    Dim strSQL As String
    Dim intResult As Integer
    '1) 删除货位批次明细表
    If lngActivityTypeID = 41 Then
        '库存期初
        If ModifyPositionWhenDeleteOutBill(lngActivityID) = False Then GoTo TheErr
    End If
    
    DeleteObtendTables = 1
    Exit Function
TheErr:
    DeleteObtendTables = -1
End Function


'////////////////////////////////////////////////////////////////////////////////
'//
'//                                 删除列表记录
'//
'////////////////////////////////////////////////////////////////////////////////
'<接口>
'blnByVoid：删除功能由作废调用
Public Function DeleteStartPeriod(arglngActivityID As Long, Optional blnByVoid As Boolean) As Boolean
    Dim strSQL As String
    Dim recTemp As rdoResultset
    Dim intResult As Integer
    '-----------------------------------------
    Dim intYear As Integer '凭证会计年度
    Dim bytPeriod As Byte   '凭证会计期间
    Dim lngReceiptTypeID As Long
    Dim strReceiptNo As String
    Dim lngReceiptNo As Long
    '------------------------------------------
    lngActivityID = arglngActivityID
    
    strDelOrVoid = IIf(blnByVoid, "作废！", "删除！")
    
    If blnPeriodClosed() Then
        cMsgBox "已有会计期间结帐，不允许" & IIf(blnByVoid, "作废", "删除") & "期初单据！"
        Exit Function
    End If
    
    strSQL = "SELECT ItemActivity.lngActivityTypeID, ItemActivity.blnIsVoid , ItemActivity.* From ItemActivity WHERE (ItemActivity.lngActivityID)=" & lngActivityID
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If recTemp.BOF And recTemp.EOF Then
        cMsgBox "列表的数据已被修改，请重新刷新后再进行操作！"
        Set recTemp = Nothing
        Exit Function
    End If
    lngActivityTypeID = recTemp(0)
    blnIsVoid = IIf(recTemp(1) = 0, False, True)
    strTypeName = BillPublic.ReceiptTypeIdToName(recTemp!lngReceiptTypeID)
    '-------------------------------------------------------------------
    intYear = gclsBase.FYearOfDate(C2Date(recTemp!strDate))
    bytPeriod = gclsBase.PeriodOfDate(C2Date(recTemp!strDate))
    lngReceiptTypeID = recTemp!lngReceiptTypeID
    strReceiptNo = recTemp!strReceiptNo
    lngReceiptNo = recTemp!lngReceiptNo
'    blnIsInvoice = recTemp!blnIsInvoice
    '--------------------------------------------------------------------
    Set recTemp = Nothing
    If Not blnByVoid Then ' 非作废操作调用无须删除提问
        If blnIsVoid = False Then
            If ShowMsg(thehWnd, "您确实要删除本张" & strTypeName & "单吗？", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "提示信息") <> IDYES Then Exit Function
        Else
            If ShowMsg(thehWnd, "您确实要删除本张已经作废的" & strTypeName & "单吗？", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "提示信息") <> IDYES Then Exit Function
        End If
    End If

    '删除作废单据无须判断
    If Not blnIsVoid Then
        If BeforeDelete(blnByVoid) <> 1 Then Exit Function '判断单据能否删除
        intResult = DeleteRelation(lngActivityID, lngActivityTypeID) '删除关系(删除采购发票与受托结算单时须标记对应商品入库单及受托入库单)
        If intResult <> 1 Then GoTo DeleteErr
    '    If intResult = -1 Then GoTo theErr
    End If
    
    On Error GoTo DeleteErr
    gclsBase.BaseWorkSpace.BeginTrans
    
    '1）单据是作废单据，不执行
    If Not blnIsVoid Then
        If ChangeAllItem_from_Activity("D", lngActivityID, True) = False Then GoTo DeleteErr
'        If ChangeAllAccount_from_Activity("D", lngActivityID) = False Then GoTo DeleteErr
        If DeleteObtendTables() <> 1 Then GoTo DeleteErr
    End If
    
    '2）作废操作不执行
    If Not blnByVoid Then
        If DeleteItemActivityANDItemActivityDetail(lngActivityID) <> 0 Then GoTo DeleteErr
    Else
        If gclsBase.ExecSQL("UPDATE ItemActivity SET ItemActivity.blnIsVoid = 1 WHERE (ItemActivity.lngActivityID)=" & lngActivityID) = False Then GoTo DeleteErr
    End If
'------------------------------------------------------------------------------
    If Not blnByVoid Then blnMaxNODecrease 0, 0, lngReceiptTypeID, strReceiptNo, lngReceiptNo
'------------------------------------------------------------------------------
    
    gclsBase.BaseWorkSpace.CommitTrans
    DeleteStartPeriod = True
    Screen.MousePointer = vbDefault
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    Exit Function
DeleteErr:
    If Not recTemp Is Nothing Then
        Set recTemp = Nothing
    End If
    gclsBase.BaseWorkSpace.RollBacktrans
    Screen.MousePointer = vbDefault
    cMsgBox Left(strDelOrVoid, 2) & strTypeName & "单失败！"
End Function