frmcommlist.frm

来自「金算盘软件代码」· FRM 代码 · 共 1,519 行 · 第 1/4 页

'反映是否有卡片存在
Public Property Let IsShowCard(ByVal vNewValue As Boolean)
    Select Case mintListType
        Case 1
            mIsShowCard(0) = vNewValue
        Case 2
            mIsShowCard(1) = vNewValue
        Case 3
            mIsShowCard(2) = vNewValue
        Case 4
            mIsShowCard(3) = vNewValue
    End Select
End Property
Public Property Get IsShowCard() As Boolean
   Select Case mintListType
        Case 1
            IsShowCard = mIsShowCard(0)
        Case 2
            IsShowCard = mIsShowCard(1)
        Case 3
            IsShowCard = mIsShowCard(2)
        Case 4
            IsShowCard = mIsShowCard(3)
    End Select
End Property


'按照币种ID更新停用标志
Private Function UpdateListInActive(ByVal lngID As Long, ByVal blnIsInActive As Boolean) As Boolean
    Dim strSql As String
    Select Case mintListType
        Case 1
            strSql = "UPDATE Currencys SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngCurrencyID = " & lngID
        Case 2
            strSql = "UPDATE VoucherType SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngVoucherTypeID = " & lngID
        Case 3
            strSql = "UPDATE PaymentMethod SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngPaymentMethodID = " & lngID
        Case 4
            strSql = "UPDATE Term SET blnIsInActive = " & IIf(blnIsInActive, 1, 0) & " WHERE lngTermID = " & lngID
    End Select
    UpdateListInActive = gclsBase.ExecSQL(strSql)
End Function

'删除币种ID指定记录

'判断币种ID是否使用

' 币种ID
Public Property Get ListID() As Long
    With msgCurrencys
        If .TextArray(.Row * .Cols) <> "" And .Row > 0 Then
            ListID = CLng(.TextArray(.Row * .Cols))
        Else
            ListID = 0
        End If
    End With
End Property

' 币种停用标志
Public Property Get ListRecIsInActive() As Boolean
    If chkShowAll.Value Then
        With msgCurrencys
            ListRecIsInActive = Not (.TextArray(.Row * .Cols + 1) = "")
        End With
    Else
        ListRecIsInActive = False
    End If
End Property

'根据列表中记录数，设置菜单可用属性
Private Sub UpdateMenuStatus()
    Dim blnIsnotEmpty As Boolean
    Dim blnFindNoChange As Boolean
    Dim IsHaveRight As Boolean
    
    'IsHaveRight = IsCanDo(22, gclsBase.OperatorID)
    With msgCurrencys
    If .Rows > 1 And .ColSel <> 0 And .RowHeight(.Row) > 0 Then
        blnIsnotEmpty = True
    Else
        blnIsnotEmpty = False
    End If
    End With
    With frmMain
        .mnuEditEdit.Caption = "修改(&E)"
        .mnuEditNew.Caption = "新增(&N)"
        .mnuEditDel.Caption = "删除(&D)"
        .mnuEditCopy.Enabled = blnIsnotEmpty
        .mnuEditEdit.Enabled = blnIsnotEmpty And mIsHaveRight
        .mnuEditNew.Enabled = True And mIsHaveRight
        .mnuEditDel.Enabled = blnIsnotEmpty And mIsHaveRight
        .mnuEditInActive.Checked = False
        .mnuEditInActive.Visible = False
        .mnuEditInActive.Enabled = blnIsnotEmpty And mIsHaveRight
        .mnuEditShowAll.Checked = chkShowAll.Value
        .mnuEditShowAll.Enabled = True
        .mnuEditUse.Enabled = blnIsnotEmpty
        .mnuEditSearch.Enabled = True
        .mnuEditColumn.Enabled = True
        .mnuEditFilter.Enabled = True
        .mnuFilePrint.Enabled = True
        .mnuFilePrintSetup.Enabled = True
        .mnuReportQuick.Enabled = blnIsnotEmpty
        .mnuToolRefresh.Enabled = True
    End With
    
    If msgCurrencys.ColSel = 0 Then  '无当前选定行
       blnFindNoChange = mclsList.FindNoChange
       mclsList.FindNoChange = True
        txtfind.Text = ""
       mclsList.FindNoChange = blnFindNoChange
        cmdAgain.Enabled = False
    End If
    frmMain.SetToolBar
End Sub

'重画Form
Private Sub RedrawForm()
    '重画MS FlexGrid 控件
    On Error Resume Next
    With msgCurrencys
        .Left = ListFormLeft
        .width = Me.ScaleWidth - ListFormLeft - ListFormRight
        .Height = Me.ScaleHeight - ListUpAreaHeight - ListDownAreaHeight
    End With
    
    '重画其余控件
    txtfind.width = Me.ScaleWidth - txtfind.Left - ListFormBottom - cmdAgain.width - 15
    cmdAgain.Left = txtfind.Left + txtfind.width
    cmdEdit.top = Me.ScaleHeight - cmdEdit.Height - ListFormBottom
    cmdReport.top = cmdEdit.top
    chkShowAll.top = cmdEdit.top
    chkShowAll.Left = Me.ScaleWidth - chkShowAll.width - ListFormBottom
End Sub

Private Sub Form_Deactivate()
    frmMain.SetEditUnEnabled
End Sub

'
'窗体 Form 控件
'
Private Sub Form_Load()
    Dim i As Integer
    Dim intSortCol As Integer
'    Me.Hide
'    Me.Left = -30000
    On Error GoTo ErrHandle
    MsgForm.PleaseWait
    Me.Caption = mstrListName & "列表"
    Select Case mintListType
        Case 1
            Me.HelpContextID = 30035
            frmMain.mnuListCurrency.Tag = Me.hwnd
            mIsHaveRight = IsCanDo(22, gclsBase.OperatorID)
        Case 2
            Me.HelpContextID = 30038
            frmMain.mnuListVoucherType.Tag = Me.hwnd
            mIsHaveRight = IsCanDo(23, gclsBase.OperatorID)
            mblnFirstLoad = True
        Case 3
            Me.HelpContextID = 30040
            frmMain.mnuListPaymentMethod.Tag = Me.hwnd
            mIsHaveRight = IsCanDo(24, gclsBase.OperatorID)
        Case 4
            Me.HelpContextID = 30042
            frmMain.mnuListTerm.Tag = Me.hwnd
            mIsHaveRight = IsCanDo(25, gclsBase.OperatorID)
    End Select
    
    '币种币率列表窗体初始化
    Debug.Print "start load form time:", Timer
    Set mclsList = New list
    mclsList.FlexNoChange = True
    mclsList.FindNoChange = True
    Set mclsList.FlexGrid = msgCurrencys
    Set mclsList.FindKind = cboFindKind
    Set mclsList.Find = txtfind
    Set mclsList.Again = cmdAgain
    mclsList.ListSet.ViewId = intViewID
    mclsList.InitFlexGrid
    
    '得到币种币率列表记录集
'    If mintListType = 2 Then
'        If Not GetList Then
'            frmInitVoucherTypeCard.AddCard
'            GetList
'        End If
'    Else
'        GetList
'    End If
'    GetList
''    Set datCurrencys.Recordset = GetList()
''    If datCurrencys.Recordset.RecordCount > 0 Then
''       datCurrencys.Recordset.MoveLast
''    End If
''    datCurrencys.Recordset.Close
'
''    Set datCurrencys.Recordset = Nothing
'    mclsList.SetFlexGrid
'
'    '初始化查找复合列表框
'    mclsList.InitcboFindKind
'    mclsList.FlexNoChange = False
'    mclsList.FindNoChange = False
'
'    '设置第一行为选定行
'    With msgCurrencys
'        If .Rows > 1 Then .Row = 1
'        .col = 0
'        .ColSel = .Cols - 1
'    End With
'    mclsList.DoShowAll False
'    UpdateMenuStatus
    
    '设置钩子对象
    Set mclsSubClass = New SubClass32.SubClass
    mclsSubClass.hwnd = msgCurrencys.hwnd
    mclsSubClass.Messages(WM_PAINT) = True
    mclsSubClass.Messages(WM_LBUTTONUP) = True
    mclsSubClass.Messages(WM_LBUTTONDOWN) = True
    mclsSubClass.Messages(WM_MOUSEMOVE) = True
    
    Set mclsSubClassform = New SubClass32.SubClass
    mclsSubClassform.hwnd = Me.hwnd
    mclsSubClassform.Messages(WM_GETMINMAXINFO) = True
    Debug.Print "last end form time:", Timer
    Unload MsgForm
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
    Exit Sub
    Dim edtErrReturn As ErrDealType
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload MsgForm
         Unload Me
    End If
End Sub

'右键菜单
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbRightButton And frmMain.ActiveForm Is Me Then
        MakeListEditMenu
        PopupMenu frmMain.mnuListEdit
    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If UnloadMode = vbFormControlMenu And UserRight.GetIsShowcard(mintListType) Then ' And ( Or UserRight.GetIsShowcard(2) Or UserRight.GetIsShowcard(3) Or UserRight.GetIsShowcard(4)) Then
        ShowMsg 0, "请先关闭" & mstrListName & "卡片！", vbExclamation
        Cancel = True
        Select Case mintListType
            Case 1
'                If frmCurrencyListCard.WindowState = 1 Then frmCurrencyListCard.WindowState = 0
'                frmCurrencyListCard.Show
'                frmCurrencyListCard.ZOrder 0
            Case 2
'                frmVoucherTypeListCard.Show
'                frmVoucherTypeListCard.ZOrder 0
            Case 3
'                frmPaymentMethodListCard.Show
'                frmPaymentMethodListCard.ZOrder 0
            Case 4
'                frmtermlistcard.Show
'                frmtermlistcard.ZOrder 0
        End Select
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    If Not mclsList Is Nothing Then mclsList.SaveListSet
    Select Case mintListType
        Case 1
'            If UserRight.GetIsShowcard(1) Then Unload frmCurrencyListCard
            frmMain.mnuListCurrency.Tag = 0
        Case 2
'            If UserRight.GetIsShowcard(2) Then Unload frmVoucherTypeListCard
            frmMain.mnuListVoucherType.Tag = 0
        Case 3
'            If UserRight.GetIsShowcard(3) Then Unload frmPaymentMethodListCard
            frmMain.mnuListPaymentMethod.Tag = 0
        Case 4
'            If UserRight.GetIsShowcard(4) Then Unload frmtermlistcard
            frmMain.mnuListTerm.Tag = 0
    End Select
    
    Set mclsSubClass = Nothing
    Set mclsSubClassform = Nothing
    Set mclsList = Nothing
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    If Me.WindowState = 1 Then Exit Sub
    If Me.Left + Me.width < 0 Or Me.Left > Screen.width Then
       Me.Left = 300
    End If
    RedrawForm
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
    On Error Resume Next
    If KeyAscii = vbKeyEscape Then
        Unload Me
    ElseIf KeyAscii = vbKeyReturn Then
        BKKEY Me.ActiveControl.hwnd, vbKeyTab
    End If
End Sub
Private Sub Form_Activate()
    On Error Resume Next
    Select Case mintListType
        Case 1
            SetHelpID 30035
        Case 2
            SetHelpID 30038
        Case 3
            SetHelpID 30040
        Case 4
            SetHelpID 30042
    End Select
    mclsMainControl_ChildActive '响应消息
    gclsSys.CurrFormName = Me.hwnd
    'msgCurrencys.SetFocus
    msgCurrencys.Redraw = True
    UpdateMenuStatus
    'If (Me.Left + Me.Width < 0 Or Me.Left > Screen.Width) Then Me.Left = 300
    If Me.WindowState = 1 Then Me.WindowState = 0
End Sub
'
'显示全部记录/未停用记录 CheckBox 控件
'
Private Sub chkShowAll_Click()
    msgCurrencys.Redraw = False
    mclsList.DoShowAll chkShowAll.Value
    'cboFindKind_Click
    UpdateMenuStatus
    msgCurrencys.Redraw = True
End Sub
'
'查找条件类型 ComboBox 控件
'
Private Sub cboFindKind_Click()
    Dim i As Integer
    Dim intWidth As Integer
    Dim strFind As String
    Dim intSortCol As Integer
    mclsList.ReGetColCaption
    With msgCurrencys
        .Redraw = False
        For i = 1 To .Cols - 1
            If .TextMatrix(0, i) = cboFindKind.Text Then
                If .RowHeight(.Row) > 0 Then strFind = .TextMatrix(.Row, i)
                mclsList.FixrowSortBold i
                Exit For
            End If
       Next
    End With
    
    If msgCurrencys.Rows > 1 Then
        If txtfind.Text = strFind Then
            txtFind_Change
        Else
            txtfind.Text = strFind
        End If
    End If
    msgCurrencys.Redraw = True
End Sub

'响应消息
Private Sub mclsMainControl_ChildActive()
    Dim vntMessage As Variant
    Dim vntCompareMessage As Variant
    
    SetHelpID Me.HelpContextID