clslistcomcvtp.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 = "clsListComCVTP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False


Private WithEvents mfrmComm As frmAListTemplate '模版窗体
Attribute mfrmComm.VB_VarHelpID = -1
Private mListType As Integer
Private clsListType As String
Public Function SetListType(ByVal strList As String)
    mfrmComm.strListType = strList
    clsListType = strList
End Function
Private Sub Class_Initialize()
    Set mfrmComm = New frmAListTemplate
    mfrmComm.blnReceptionList = False
    mListType = GetListType
    mfrmComm.Tabs = 1
    Select Case mListType
        Case 1
            mfrmComm.mTitle = "币种汇率列表"
            mfrmComm.mHelpID = 30035
            
            mfrmComm.SpViewID(0) = 15
            mfrmComm.SpSelect(0) = "Currencys.lngCurrencyID As id,decode(Currencys.blnIsInActive,1,'√',' ') As ""停用"""
            mfrmComm.blnEditByRight(0) = IsCanDo(22, gclsBase.OperatorID)
            mfrmComm.SpPrintID(0) = 29
            mfrmComm.SpPrintTitle(0) = "币种汇率列表" & Chr(1) & gclsBase.BaseName & Chr(1) & gclsBase.OperatorName
            mfrmComm.ShowAll(0) = " Currencys.blnIsInActive=0"
        Case 2
            If Not IsHavingVoucherType Then
                frmInitVoucherTypeCard.Show vbModal
                Set frmInitVoucherTypeCard = Nothing
            End If
            mfrmComm.mTitle = "凭证类型列表"
            mfrmComm.mHelpID = 30038
            
            mfrmComm.SpViewID(0) = 14
            mfrmComm.SpSelect(0) = "VoucherType.lngVoucherTypeID As id,decode(VoucherType.blnIsInActive,1,'√',' ') As ""停用"""
            mfrmComm.blnEditByRight(0) = IsCanDo(23, gclsBase.OperatorID)
            mfrmComm.SpPrintID(0) = 30
            mfrmComm.SpPrintTitle(0) = "凭证类型列表" & Chr(1) & gclsBase.BaseName & Chr(1) & gclsBase.OperatorName
            mfrmComm.ShowAll(0) = " VoucherType.blnIsInActive=0"
        Case 3
            mfrmComm.mTitle = "付款方式列表"
            mfrmComm.mHelpID = 30040
            mfrmComm.SpViewID(0) = 17
            
            mfrmComm.SpSelect(0) = "PaymentMethod.lngPaymentMethodID As id,decode(PaymentMethod.blnIsInActive,1,'√',' ') As ""停用"""
            mfrmComm.blnEditByRight(0) = IsCanDo(24, gclsBase.OperatorID)
            mfrmComm.SpPrintID(0) = 31
            mfrmComm.SpPrintTitle(0) = "付款方式列表" & Chr(1) & gclsBase.BaseName & Chr(1) & gclsBase.OperatorName
            mfrmComm.ShowAll(0) = "PaymentMethod.blnIsInActive=0"
        Case 4
            mfrmComm.mTitle = "付款条件列表"
            mfrmComm.mHelpID = 30042
            mfrmComm.SpViewID(0) = 18
            
            mfrmComm.SpSelect(0) = "Term.lngTermID As id,decode(Term.blnIsInActive,1,'√',' ') As ""停用"""
            mfrmComm.blnEditByRight(0) = IsCanDo(25, gclsBase.OperatorID)
            mfrmComm.SpPrintID(0) = 32
            mfrmComm.SpPrintTitle(0) = "付款条件列表" & Chr(1) & gclsBase.BaseName & Chr(1) & gclsBase.OperatorName
            mfrmComm.ShowAll(0) = " Term.blnIsInActive=0"
    End Select
    
    If mListType = 1 Then
        mfrmComm.SpMenuCount = 1
        mfrmComm.SpPosition = 7
        mfrmComm.SpMenuName(0) = "清除过时汇率(&Z)"
        mfrmComm.SpEnableOnPageNo(0) = 1
        mfrmComm.blnConstant(0) = False
    End If
    mfrmComm.MenuEnbaleOnPage(0) = 3
    mfrmComm.MenuEnbaleOnPage(1) = 3
    mfrmComm.MenuEnbaleOnPage(2) = 3
    mfrmComm.MenuEnbaleOnPage(3) = 3
    mfrmComm.MenuEnbaleOnPage(4) = 3
    mfrmComm.MenuEnbaleOnPage(5) = 3
    mfrmComm.MenuEnbaleOnPage(6) = 3
    mfrmComm.MenuEnbaleOnPage(7) = 3
End Sub

Public Function Showlist()
    mfrmComm.Show
    mfrmComm.ZOrder 0
End Function

Private Sub mfrmComm_ListChildActive()
    Dim vntMessage As Variant
    Dim vntCompareMessage As Variant
    Select Case mListType
        Case 1
            vntCompareMessage = Message.msgcurrency
        Case 2
            vntCompareMessage = Message.msgVoucherType
        Case 3
            vntCompareMessage = Message.msgPaymentMethod
        Case 4
            vntCompareMessage = Message.msgTerm
    End Select
    '响应消息
    For Each vntMessage In mfrmComm.mclsMainControl.Messages
        If vntMessage = vntCompareMessage Then mfrmComm.ToolRefresh
        mfrmComm.mclsMainControl.Messages.Remove CStr(vntMessage) '清除部门雇员改变消息
    Next
    mfrmComm.mclsMainControl.Messages.Clear
End Sub

Private Sub mfrmComm_ListDel()
    Dim lngID As Long
    Dim blnSucess As Boolean
    lngID = mfrmComm.ListID
    If lngID = 0 Then Exit Sub
    blnSucess = False
    Select Case mListType
        Case 1
            If lngID = 1 Then
                MsgBox "不能删除本位币", vbExclamation
            Else
                blnSucess = frmCurrencyCard.DelCard(lngID, mfrmComm.hWnd, True)
                Unload frmCurrencyCard
                Set frmCurrencyCard = Nothing
            End If
        Case 2
            blnSucess = frmEntryTypeCard.DelCard(lngID, mfrmComm.hWnd, True)
            Unload frmEntryTypeCard
            Set frmEntryTypeCard = Nothing
        Case 3
            blnSucess = frmPaymentMethodCard.DelCard(lngID, mfrmComm.hWnd, True)
            Unload frmEntryTypeCard
            Set frmEntryTypeCard = Nothing
        Case 4
            blnSucess = frmTermCard.DelCard(lngID, mfrmComm.hWnd, True)
            Unload frmTermCard
            Set frmTermCard = Nothing
    End Select
    If blnSucess Then
        With mfrmComm
           .ToolRefresh
        End With
        Select Case mListType
                Case 1
                    gclsSys.SendMessage CStr(mfrmComm.hWnd), Message.msgcurrency
                Case 2
                    gclsSys.SendMessage CStr(mfrmComm.hWnd), Message.msgVoucherType
                Case 3
                    gclsSys.SendMessage CStr(mfrmComm.hWnd), Message.msgPaymentMethod
                Case 4
                    gclsSys.SendMessage CStr(mfrmComm.hWnd), Message.msgTerm
            End Select
    End If
End Sub

Private Sub mfrmComm_ListEdite()
    Dim lngID As Long
    lngID = mfrmComm.ListID
    mfrmComm.Enabled = False
    mfrmComm.MousePointer = vbHourglass
    Select Case mListType
        Case 1
            If CheckIDUsed("Currencys", "lngCurrencyID", lngID) Then
                    frmCurrencyCard.EditCard lngID, vbModal
                    Set frmCurrencyCard = Nothing
                    bCancel = False
                Else
                    bCancel = True
                End If
        Case 2
            If CheckIDUsed("VoucherType", "lngVoucherTypeID", lngID) Then
                    frmEntryTypeCard.EditCard lngID, vbModal
                    Set frmEntryTypeCard = Nothing
                    bCancel = False
                Else
                    bCancel = True
                End If
        Case 3
            If CheckIDUsed("paymentMethod", "lngpaymentMethodID", lngID) Then
                    frmPaymentMethodCard.EditCard lngID, vbModal
                    Set frmPaymentMethodCard = Nothing
                    bCancel = False
                Else
                    bCancel = True
                End If
        Case 4
            If CheckIDUsed("Term", "lngTermID", lngID) Then
                    frmTermCard.EditCard lngID, vbModal
                    Set frmTermCard = Nothing
                    bCancel = False
                Else
                    bCancel = True
                End If
    End Select
    If bCancel Then
        bCancel = False
        ShowMsg 0, "该" & Choose(mListType, "币种汇率", "凭证类型", "付款方式", "付款条件") & "不存在，不能进行修改！", vbExclamation + MB_TASKMODAL, Choose(mListType, "币种汇率", "凭证类型", "付款方式", "付款条件") & "列表"
        mfrmComm.ToolRefresh
    End If
    mfrmComm.MousePointer = vbDefault
    mfrmComm.Enabled = True
End Sub

Private Sub mfrmComm_oListInActive()
    Dim strCode As String
    Dim lngID As Long
    Dim blnRemark As Boolean
    
    lngID = mfrmComm.ListID
    If lngID = 0 Then Exit Sub
    blnRemark = ListIsInActive(mListType, lngID, strCode)
    If mListType = 1 Then
        If lngID = 1 Then
            MsgBox "本位币不能停用", vbExclamation, mfrmComm.Caption
            Exit Sub
        End If
    End If
    If UpdateIsActive(mListType, lngID, Not blnRemark, False) Then
        mfrmComm.ToolRefresh
        Select Case mListType
            Case 1
                gclsSys.SendMessage CStr(mfrmComm.hWnd), Message.msgcurrency
            Case 2
                gclsSys.SendMessage CStr(mfrmComm.hWnd), Message.msgVoucherType
            Case 3
                gclsSys.SendMessage CStr(mfrmComm.hWnd), Message.msgPaymentMethod
            Case 4
                gclsSys.SendMessage CStr(mfrmComm.hWnd), Message.msgTerm
        End Select
    End If
End Sub


Private Sub mfrmComm_ListInActive(blnLevel As Boolean, blnSuceess As Boolean)
    Dim strCode As String
    Dim lngID As Long
    Dim blnRemark As Boolean
    
    blnLevel = False
    blnSuceess = False
    lngID = mfrmComm.ListID
    If lngID = 0 Then Exit Sub
    blnRemark = ListIsInActive(mListType, lngID, strCode)
    If mListType = 1 Then
        If lngID = 1 Then
            MsgBox "本位币不能停用", vbExclamation, mfrmComm.Caption
            Exit Sub
        End If
    End If
    If UpdateIsActive(mListType, lngID, Not blnRemark, False) Then
        'mfrmComm.ToolRefresh
        blnSuceess = True
        Select Case mListType
            Case 1
                gclsSys.SendMessage CStr(mfrmComm.hWnd), Message.msgcurrency
            Case 2
                gclsSys.SendMessage CStr(mfrmComm.hWnd), Message.msgVoucherType
            Case 3
                gclsSys.SendMessage CStr(mfrmComm.hWnd), Message.msgPaymentMethod
            Case 4
                gclsSys.SendMessage CStr(mfrmComm.hWnd), Message.msgTerm
        End Select
    End If

End Sub

Private Sub mfrmComm_ListNew()
    mfrmComm.MousePointer = vbHourglass
    Select Case mListType
        Case 1
            frmCurrencyCard.AddCard , vbModal
            Set frmCurrencyCard = Nothing
        Case 2
            frmEntryTypeCard.AddCard , vbModal
            Set frmEntryTypeCard = Nothing
        Case 3
            frmPaymentMethodCard.AddCard , vbModal
            Set frmPaymentMethodCard = Nothing
        Case 4
            frmTermCard.AddCard , vbModal
            Set frmTermCard = Nothing
    End Select
    mfrmComm.MousePointer = vbDefault
End Sub

Private Sub mfrmComm_ListShowAll()
    With mfrmComm
        If .chkShowall = 0 Then
            Select Case mListType
                Case 1
                    .ShowAll(0) = " Currencys.blnIsInActive=0"
                Case 2
                    .ShowAll(0) = " VoucherType.blnIsInActive=0"
                Case 3
                    .ShowAll(0) = " PaymentMethod.blnIsInActive=0"
                Case 4
                    .ShowAll(0) = " Term.blnIsInActive=0"
            End Select
        Else
            Select Case mListType
                Case 1
                    .ShowAll(0) = ""
                     '.SpSelect(0) = "Currencys.lngCurrencyID As id,IIF(Currencys.blnIsInActive,'√','') As 停用"
                Case 2
                    .ShowAll(0) = ""
                Case 3
                    .ShowAll(0) = ""
                Case 4
                    .ShowAll(0) = ""
            End Select
        End If
        .ToolRefresh
    End With
End Sub

Private Sub mfrmComm_ListUsed()
    Dim lngID As Long
    
    lngID = mfrmComm.ListID
    Select Case mListType
        Case 1
            UseCode Message.msgcurrency, lngID
        Case 2
            UseCode Message.msgVoucherType, lngID
        Case 3
            UseCode Message.msgPaymentMethod, lngID
        Case 4
            UseCode Message.msgTerm, lngID
    End Select
    mfrmComm.ZOrder 1
End Sub

Private Function UpdateIsActive(ByVal intTab As Integer, ByVal strCode As String, ByVal blnIsInActive As Boolean, ByVal blnYes As Boolean) As Boolean
    Dim strSql As String
    Select Case intTab
        Case 1
            strSql = "UPDATE Currencys SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngCurrencyID = " & strCode
        Case 2
            strSql = "UPDATE VoucherType SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngVoucherTypeID = " & strCode
        Case 3
            strSql = "UPDATE PaymentMethod SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngPaymentMethodID = " & strCode
        Case 4
            strSql = "UPDATE Term SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngTermID = " & strCode
    End Select
    UpdateIsActive = gclsBase.ExecSQL(strSql)
End Function

Private Function ListIsInActive(ByVal intTab As Integer, ByVal lngID As Long, strCode As String) As Boolean
    Dim recTmp As rdoResultset
    Dim strSql As String
    Select Case intTab
        Case 1
            strSql = "Select blnIsInActive,strCurrencyCode As Code from Currencys Where lngCurrencyID=" & lngID
        Case 2
            strSql = "Select blnIsInActive,strVoucherTypeCode As Code from VoucherType Where lngVoucherTypeID=" & lngID
        Case 3
            strSql = "Select blnIsInActive,strPaymentMethodCode As Code from PaymentMethod Where lngPaymentMethodID=" & lngID
        Case 4
            strSql = "Select blnIsInActive,strTermCode As Code from Term Where lngTermID=" & lngID
    End Select
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recTmp.EOF Then
        ListIsInActive = IIf(recTmp!blnIsInActive = 1, True, False)
        strCode = recTmp!Code
    End If
End Function

Private Sub mfrmComm_ListUserMenu(ByVal Index As Integer)
    If mListType = 1 Then
        If Index = 7 Then frmClearRate.ClearRate (mfrmComm.ListID)   '清除过时汇率
    End If
End Sub

Private Function IsHavingVoucherType() As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    strSql = "Select lngVoucherTypeID from VoucherType"
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If recTmp.RowCount = 0 Then
        IsHavingVoucherType = False
    Else
        IsHavingVoucherType = True
    End If
End Function

Public Function ShowEachList(ByVal lngID As Long, Optional intTab As Integer = 0) As Boolean
    strWhere = Choose(mListType, "Currencys.lngCurrencyID=", "VoucherType.lngVoucherTypeID=", "PaymentMethod.lngPaymentMethodID=", "Term.lngTermID=") & lngID
    ShowEachList = mfrmComm.Showlist(lngID, intTab, strWhere)
End Function