clslist.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 = "clsListMethod"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
 '王成

Option Explicit

'局部变量保存属性值
Private mvartheType As Integer '处理类型：1：收款单 2：付款单 3：应收单 4：应付单
Private myGrd As MSFlexGrid
Private strMsg As String
Private thehWnd As Long
Private blnTrans As Boolean   '是否提交事务标志
Private mblnIsBill As Boolean   '是否是从单据调用标志
Private lngReceiptTypeID As Long '单据类型ID
Private mlngOperatorID As Long          '操作员ID
Private mblnVoid As Boolean             '作废标志
Private mlngVoucherID As Long           '记帐凭证ID
Private mlngItemActivityID As Long      '商品业务ID

'-------------------------------------------------------------------------------------
'
'                                      属  性
'
'-------------------------------------------------------------------------------------
'
Public strListName As String
'是否从单据中调用标志属性
Public Property Get blnIsBill() As Boolean
    blnIsBill = mblnIsBill
End Property
Public Property Let blnIsBill(ByVal vData As Boolean)
    mblnIsBill = vData
End Property
'-------------------------------------------------------------------------------------
'
'                                      方  法
'
'-------------------------------------------------------------------------------------
'
Public Sub SethWnd(arghWnd As Long)
    thehWnd = arghWnd
End Sub

'
Public Property Let theType(ByVal vData As Integer)
    mvartheType = vData
    If vData = 1 Then
        strListName = "收款单"
    
    ElseIf vData = 2 Then
        strListName = "付款单"

    ElseIf vData = 3 Then
        strListName = "应收单"
     
    ElseIf vData = 4 Then
        strListName = "应付单"
     
    End If
    
End Property

Public Function DeleteRow(ByVal lngActivityID As Long, _
                            Optional ByVal blnByVoid As Boolean = False, _
                            Optional ByVal blnShowMsg As Boolean = True, _
                            Optional ByVal blnDeleteCash As Boolean = False) As Boolean
    Dim lngWriteOffID() As Long '存贮冲销单据ID
    Dim intI As Integer     '删除冲销单据盾环变量
    '-----------------------------------------
    Dim strSQL As String
    Dim intResult As Integer
    Dim lngTmp As Long
''不能删除不是本人填制的单据
    If GetReceiptStatus(lngActivityID) = False Then Exit Function
    
    If mlngOperatorID = 0 Then
        DeleteRow = True
        Exit Function
    ElseIf mlngOperatorID <> gclsBase.OperatorID Then
        If blnShowMsg Then
            If blnByVoid Then
                cMsgBox "您不能作废他人制的单据！", "警告信息"
            Else
                cMsgBox "您不能删除他人制的单据！", "警告信息"
            End If
        End If
        GoTo endproc
    End If
    If blnDeleteCash = False Then
        If mlngItemActivityID > 0 Then
            If blnShowMsg Then
                cMsgBox "本张" & strListName & "是现款结算单据，不能" & IIf(blnByVoid = False, "删除", "作废") & "！"
            End If
            GoTo endproc
        End If
    End If
    
'1).如果本张收（付）款单已经生成相应的记帐凭证，则本张收（付）款单不能删除，应给出相应的提示信息
    If mlngVoucherID > 0 Then
        If blnShowMsg Then
            cMsgBox "本张" & strListName & "已经生成记帐凭证，不能" & IIf(blnByVoid = False, "删除", "作废") & "！"
        End If
        GoTo endproc
    End If
    If mblnVoid Then
        If blnShowMsg Then
            If ShowMsg(thehWnd, "您确实要" & IIf(blnByVoid = False, "删除", "作废") & "本张已经作废了的" & strListName & "吗？", vbQuestion + vbYesNo + vbDefaultButton2, IIf(blnByVoid = False, "删除", "作废") & "提示") <> vbYes Then GoTo endproc
        End If
    Else
        If blnShowMsg Then
            If ShowMsg(thehWnd, "您确实要" & IIf(blnByVoid = False, "删除", "作废") & "本张" & strListName & "吗？", vbQuestion + vbYesNo + vbDefaultButton2, IIf(blnByVoid = False, "删除", "作废") & "提示") <> vbYes Then GoTo endproc
        End If
    End If
''''''''''''''''''''''''''''''''''''''''
        If blnDeleteCash = False Then gclsBase.BaseWorkSpace.BeginTrans
'删除冲销单据
    If blnIsWriteOffBill(lngActivityID) Then
        If BillPublic.blnDelWriteOffBillNote(thehWnd, lngReceiptTypeID, lngActivityID, IIf(blnByVoid = False, "删除", "作废")) = False Then
            GoTo endproc
        End If
        If DeleteRow1(lngActivityID, blnByVoid, False, True) Then
            If blnDeleteCash = False Then gclsBase.BaseWorkSpace.CommitTrans
            DeleteRow = True
        Else
            If blnDeleteCash = False Then gclsBase.BaseWorkSpace.RollBacktrans
            DeleteRow = False
        End If
    Else
        
        If BillPublic.blnWriteOff(thehWnd, lngReceiptTypeID, lngActivityID, "", lngWriteOffID()) = True Then
            GoTo endproc
        End If
        
        '源单据有冲销单据
        For intI = LBound(lngWriteOffID) To UBound(lngWriteOffID)
            If lngWriteOffID(intI) > 0 Then
            '1).如果本张收（付）款单已经生成相应的记帐凭证，则本张收（付）款单不能删除，应给出相应的提示信息
                intResult = IsVoucher(lngWriteOffID(intI))
                If intResult = -1 Then
                    GoTo Next1
                ElseIf intResult = 1 Then
                    If blnDeleteCash = False Then gclsBase.BaseWorkSpace.RollBacktrans
                    If blnShowMsg Then
                        cMsgBox "本张" & strListName & "的冲消单据已经生成记帐凭证，不能" & IIf(blnByVoid = False, "删除", "作废") & "！"
                    End If
                    GoTo endproc
                End If
                If DeleteRow1(lngWriteOffID(intI), blnByVoid, False, False) = False Then
                    If blnDeleteCash = False Then gclsBase.BaseWorkSpace.RollBacktrans
                    GoTo endproc
                End If
Next1:
            End If
        Next intI
        
        If blnDisCountID(lngActivityID, lngWriteOffID()) = False Then
            GoTo endproc
        End If
        
        '源单据有折扣单据
        For intI = LBound(lngWriteOffID) To UBound(lngWriteOffID)
            If lngWriteOffID(intI) > 0 Then
            '1).如果本张收（付）款单已经生成相应的记帐凭证，则本张收（付）款单不能删除，应给出相应的提示信息
                intResult = IsVoucher(lngWriteOffID(intI))
                If intResult = -1 Then
                    GoTo NextOne
                ElseIf intResult = 1 Then
                    If blnDeleteCash = False Then gclsBase.BaseWorkSpace.RollBacktrans
                    If blnShowMsg Then
                        cMsgBox "本张" & strListName & "的折扣单据已经生成记帐凭证，不能删除！"
                    End If
                    GoTo endproc
                End If
                If DeleteRow1(lngWriteOffID(intI), False, False, False) = False Then
                    If blnDeleteCash = False Then gclsBase.BaseWorkSpace.RollBacktrans
                    GoTo endproc
                End If
            End If
NextOne:
        Next intI
        
        If DeleteRow1(lngActivityID, blnByVoid, False, blnShowMsg) = True Then
            If blnDeleteCash = False Then gclsBase.BaseWorkSpace.CommitTrans
            DeleteRow = True
        Else
            If blnDeleteCash = False Then gclsBase.BaseWorkSpace.RollBacktrans
            DeleteRow = False
        End If
    End If

endproc:
    Erase lngWriteOffID
End Function

'作废
'lngActivityID：要作废的单据号
Public Function ChangeVoid(lngActivityID As Long, Optional ByVal blnIsShowMsg As Boolean = True) As Boolean
    ChangeVoid = DeleteRow(lngActivityID, True, blnIsShowMsg)
End Function
'-------------------------------------------------------------------------------------------------------------
'
'                                   内部功能函数
'
'-------------------------------------------------------------------------------------------------------------
'对话框函数
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 GetReceiptStatus(ByVal lngActivityID As Long) As Boolean
    Dim strSQL As String
    Dim recTmp As rdoResultset
    On Error GoTo endproc
        
    strSQL = "SELECT lngReceiptTypeID,lngVoucherID,lngOperatorID,blnIsVoid,lngItemActivityID FROM Activity WHERE lngActivityID = " & lngActivityID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenForwardOnly)
    If recTmp.BOF And recTmp.EOF Then
        lngReceiptTypeID = 0
        mlngVoucherID = 0
        mlngOperatorID = 0
        mlngItemActivityID = 0
    Else
        lngReceiptTypeID = recTmp("lngReceiptTypeID")
        mlngVoucherID = recTmp("lngVoucherID")
        mlngOperatorID = recTmp("lngOperatorID")
        mblnVoid = IIf(recTmp("blnIsVoid") = 0, False, True)
        mlngItemActivityID = IIf(IsNull(recTmp("lngItemActivityID")), 0, recTmp("lngItemActivityID"))
        GetReceiptStatus = True
    End If
    recTmp.Close
    Set recTmp = Nothing
    Exit Function
endproc:
End Function

'判断单据是否作废
Public Function IsVoid(lngActivityID As Long) As Integer
    Dim strSQL As String
    Dim Q_Tmp As rdoQuery
    Dim rec As Integer
    
    Set Q_Tmp = New rdoQuery
    strSQL = "{? = CALL " & gclsBase.UID & ".IsVoid(" & lngActivityID & ")}"
    Q_Tmp.SQL = strSQL
    Set Q_Tmp.ActiveConnection = gclsBase.BaseDB
    Q_Tmp(0).Direction = rdParamReturnValue
    Q_Tmp(0).Type = rdTypeNUMERIC
    Q_Tmp.Execute
    rec = Q_Tmp(0).Value
    If rec = 2 Then
        cMsgBox strListName & "的数据已被修改，请重新刷新后再进行操作！"
        IsVoid = -1
        Exit Function
    Else
        IsVoid = rec
    End If
    
    Set Q_Tmp = Nothing
    
'    Dim strSQL As String
'    Dim recTemp As rdoResultset
'
'    strSQL = "SELECT Activity.blnIsVoid From Activity  WHERE Activity.lngActivityID = " & lngActivityID
'    Set recTemp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
'    If recTemp.BOF And recTemp.EOF Then
'        cMsgBox strListName & "的数据已被修改，请重新刷新后再进行操作！"
'        IsVoid = -1
'        Exit Function
'    End If
'
'    If recTemp(0) <> 0 Then
'        IsVoid = 1 '作废
'    Else
'        IsVoid = 0 '没有作废
'    End If
    
End Function

'判断单据是否已收款或付款或被勾对
Public Function IsDoIt(lngActivityID As Long) As Integer
    Dim strSQL As String
    Dim Q_Tmp As rdoQuery
    Dim rec As Integer
    
    Set Q_Tmp = New rdoQuery