clslist.cls

金算盘软件代码

    strSQL = "{? = CALL " & gclsBase.UID & ".IsDoit(" & 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 & "的数据已被修改，请重新刷新后再进行操作！"
        IsDoIt = -1
        Exit Function
    Else
        IsDoIt = rec
    End If
    
    Set Q_Tmp = Nothing

'    Dim strSQL As String
'    Dim recTemp As rdoResultset
'
'    strSQL = "SELECT Sum(ActivityDetail.dblCurrPaymentAmount) AS dblCurrPaymentAmountOfSum " _
'            & " From ActivityDetail" _
'            & " Where ActivityDetail.lngActivityID =" & lngActivityID _
'            & " GROUP BY ActivityDetail.lngActivityID"
'
'    Set recTemp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
'    If recTemp.BOF And recTemp.EOF Then
'        cMsgBox strListName & "的数据已被修改，请重新刷新后再进行操作！"
'        IsDoIt = -1
'        Exit Function
'    End If
'
'    If CDbl(recTemp(0)) <> 0 Then
'        IsDoIt = 1
'    Else
'        IsDoIt = 0
'    End If
End Function


'判断单据是否已生成凭证
Public Function IsVoucher(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 & ".IsVoucher(" & 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 & "的数据已被修改，请重新刷新后再进行操作！"
        IsVoucher = -1
        Exit Function
    Else
        IsVoucher = rec
    End If
    
    Set Q_Tmp = Nothing

'    Dim strSQL As String
'    Dim recTemp As rdoResultset
'
'    If lngActivityID < 1 Then
'        IsVoucher = 0
'        Exit Function
'    End If
'
'    strSQL = "SELECT Activity.lngVoucherID From Activity" _
'            & " WHERE Activity.lngActivityID = " & lngActivityID
'    Set recTemp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
'    If recTemp.BOF And recTemp.EOF Then
'        cMsgBox strListName & "的数据已被修改，请重新刷新后再进行操作！"
'        IsVoucher = -1
'        Exit Function
'    End If
'    If recTemp(0) > 0 Then
'        IsVoucher = 1 ' 已生成凭证
'    Else
'        IsVoucher = 0 '没有
'    End If
    
End Function

'取出产生此折扣单据的单据的单据ID号
Private Function blnDisCountID(ByVal lngActivityID As Long, lngWriteOffID() As Long) As Boolean
    Dim recTmp As rdoResultset
    Dim strSQL As String
    Dim intJ As Long
    
    On Error GoTo ErrHandle
    intJ = 0
    ReDim lngWriteOffID(intJ)
    lngWriteOffID(intJ) = 0
    strSQL = "SELECT lngDiscountActivityID FROM ActivityDetail WHERE lngDiscountActivityID>0 AND lngActivityID=" & lngActivityID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If Not (recTmp.BOF And recTmp.EOF) Then
        recTmp.MoveLast
        recTmp.MoveFirst
        Do While Not recTmp.EOF
            ReDim Preserve lngWriteOffID(intJ)
            lngWriteOffID(intJ) = recTmp(0)
            intJ = intJ + 1
            recTmp.MoveNext
        Loop
    End If
    recTmp.Close
    Set recTmp = Nothing
    blnDisCountID = True
    Exit Function
ErrHandle:
    If Not recTmp Is Nothing Then
        Set recTmp = Nothing
    End If
End Function
'---------------------------------
'删除“科目发生额表”
Public Function DelTheDetaily(ByVal lngActivityID As Long) As Boolean
    DelTheDetaily = mdlAccount.ChangeAllAccount_from_Invoice("D", lngActivityID)
    Exit Function
End Function

'当单子是财务费用时，则还要对单位表进行维护
Private Function blnModifyCWFYDate(ByVal lngActivityID As Long) As Boolean
    Dim strSQL As String
    Dim Q_Tmp As rdoQuery
    Dim rec As Integer
    On Error GoTo endproc
    Set Q_Tmp = New rdoQuery
    strSQL = "{? = CALL " & gclsBase.UID & ".blnModifyCWFYDate(" & lngActivityID & ")}"
    Q_Tmp.SQL = strSQL
    Set Q_Tmp.ActiveConnection = gclsBase.BaseDB
    Q_Tmp(0).Type = rdTypeNUMERIC
    Q_Tmp(0).Direction = rdParamReturnValue
    Q_Tmp.Execute
    rec = Q_Tmp(0).Value
    blnModifyCWFYDate = IIf(rec = 0, True, False)
endproc:
    Set Q_Tmp = Nothing

'    Dim lngCusID As Long
'    Dim lngReceiptTypeID As Long
'    Dim strDate As String
'    Dim lngActID As Long
'    Dim strSQL As String
'    Dim recTmp As rdoResultset
'
'    On Error GoTo ErrDo
'    '---------------------------
'    lngReceiptTypeID = 38   '财务费用
'    '---------------------------
'    blnModifyCWFYDate = True
'    '先确定是否为财务费用单子
'    strSQL = "SELECT lngReceiptTypeID FROM Activity Where lngActivityID=" & lngActivityID
'    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenForwardOnly)
'    If recTmp Is Nothing Then Exit Function
'    If recTmp.BOF And recTmp.EOF Then GoTo ErrDo
'    If recTmp!lngReceiptTypeID <> lngReceiptTypeID Then
'        Set recTmp = Nothing
'        Exit Function
'    End If
''是财务费用单
'    '据业务ID找出其对应的单位ID
'    strSQL = "SELECT lngCustomerID FROM ActivityDetail WHERE lngActivityID=" & lngActivityID & " AND blnIsReceipt <> 0"
'    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenForwardOnly)
'    If recTmp Is Nothing Then GoTo ErrDo
'    If recTmp.BOF And recTmp.EOF Then GoTo ErrDo
'    lngCusID = recTmp!lngCustomerID
'    recTmp.Close
'    Set recTmp = Nothing
''--------------------------BEGIN------------------
'    strSQL = "SELECT Activity.lngActivityID,Activity.strDate " & _
'            "FROM Activity,ActivityDetail " & _
'            " WHERE ROWNUM <= 1 AND Activity.lngActivityID=ActivityDetail.lngActivityID " & _
'            " AND Activity.lngReceiptTypeID= " & lngReceiptTypeID & _
'            " AND Activity.blnIsVoid = 0 AND ActivityDetail.lngCustomerID=" & lngCusID & _
'            " AND Activity.lngActivityID<>" & lngActivityID & " ORDER BY Activity.strDate DESC"
'
'    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
'    If recTmp Is Nothing Then GoTo ErrDo
'    If Not (recTmp.BOF And recTmp.EOF) Then    '说明还有其它财务费用单子
'        lngActID = recTmp!lngActivityID
'        strDate = recTmp!strDate
'    Else                                       '说明只有这一张财务费用的单子
'        lngActID = 0
'        strDate = ""
'    End If
'    recTmp.Close
'    Set recTmp = Nothing
'    '将单位表中的相应字段更新
'    strSQL = "UPDATE Customer SET strLastFCDate = '" & strDate & "',lngLastFCReceiptID = " & lngActID & " WHERE lngCustomerID=" & lngCusID
'    If gclsBase.ExecSQL(strSQL) = False Then GoTo ErrDo
'    Exit Function
'ErrDo:
'    blnModifyCWFYDate = False
'    If Not recTmp Is Nothing Then
'        recTmp.Close
'        Set recTmp = Nothing
'    End If
''------------------------END--------------------------------
End Function

'确定是否为折扣单据(RETURN: >1 Yes , 0 NO , -1 Error ) (WXY)，并返回生成折扣单据的单据ID号
Public Function blnIsDisCountBill(ByVal lngActivityID As Long) As Long
    Dim strSQL As String
    Dim Q_Tmp As rdoQuery
    Dim rec As Integer
    
    Set Q_Tmp = New rdoQuery
    strSQL = "{? = CALL " & gclsBase.UID & ".blnIsDiscountBill(" & 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
        blnIsDisCountBill = -1
    Else
        blnIsDisCountBill = rec
    End If
    
    Set Q_Tmp = Nothing

'    Dim strSQL As String
'    Dim recTmp As rdoResultset
'    Dim blnIsDiscount As Boolean
'
'
'    strSQL = "SELECT blnIsDiscount FROM Activity WHERE lngActivityID = " & lngActivityID
'    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenForwardOnly)
'
'    If recTmp.BOF And recTmp.EOF Then
'        blnIsDisCountBill = -1
'        recTmp.Close
'        Set recTmp = Nothing
'        Exit Function
'    Else
'        blnIsDiscount = IIf(recTmp!blnIsDiscount = 0, False, True)
'    End If
'    If blnIsDiscount Then
'        strSQL = "SELECT lngActivityID FROM ActivityDetail WHERE lngDiscountActivityID = " & lngActivityID
'        Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
'        If recTmp Is Nothing Then
'            blnIsDisCountBill = -1
'            Exit Function
'        End If
'        If recTmp.BOF And recTmp.EOF Then
'            blnIsDisCountBill = 0
'        Else
'            blnIsDisCountBill = recTmp!lngActivityID
'        End If
'    Else
'        blnIsDisCountBill = 0
'    End If
'    recTmp.Close
'    Set recTmp = Nothing
End Function

'删除单据
'参数：
'lngActivityID：要删除的收（付）款单号
'blnByVoid：删除功能由作废调用
Public Function DeleteRow1(lngActivityID As Long, _
                            Optional blnByVoid As Boolean = False, _
                            Optional blnTrans As Boolean = True, _
                            Optional blnShowMsg As Boolean = True) As Boolean
    Dim strSQL As String        'string Variant
    Dim recTemp As rdoResultset    '
    Dim intResult As Long       '询问对话框的返回变量
    Dim blnIsOldVoid As Boolean '是否是已经作废标志
    Dim blnDisCount As Boolean  '是否是折扣单据标志
    Dim bIsDoIt As Boolean      '是否已核销标志
    Dim intYear As Integer      '凭证会计年度
    Dim bytPeriod As Byte       '凭证会计期间
    Dim strReceiptNo As String  '单据号前缀
    Dim lngReceiptNo As Long    '单据号后缀
    
'取出年度、期间、单据号等
    strSQL = "SELECT * From Activity WHERE lngActivityID = " & lngActivityID
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenForwardOnly)
    If recTemp.BOF And recTemp.EOF Then
        recTemp.Close
        Set recTemp = Nothing
        DeleteRow1 = True
        Exit Function
    End If
    '-------------------------------------------------------------------
    intYear = gclsBase.FYearOfDate(C2Date(recTemp!strDate))
    bytPeriod = gclsBase.PeriodOfDate(C2Date(recTemp!strDate))
    strReceiptNo = recTemp!strReceiptNo
    lngReceiptNo = recTemp!lngReceiptNo
    '--------------------------------------------------------------------
    recTemp.Close

'确定是否是折扣单据
    blnDisCount = False
    intResult = blnIsDisCountBill(lngActivityID)