frmvouchertypelist.frm

金算盘软件代码

    IsHaveRight = IsCanDo(23, gclsBase.OperatorID)
    If msgTerm.Rows > 1 And msgTerm.ColSel <> 0 And msgTerm.RowHeight(msgTerm.Row) > 0 Then
        blnIsnotEmpty = True
    Else
        blnIsnotEmpty = False
    End If
    With frmMain
        .mnuEditEdit.Caption = "修改(&E)"
        .mnuEditNew.Caption = "新增(&N)"
        .mnuEditDel.Caption = "删除(&D)"
        .mnuEditCopy.Enabled = blnIsnotEmpty
        .mnuEditEdit.Enabled = blnIsnotEmpty And IsHaveRight
        .mnuEditNew.Enabled = True And IsHaveRight
        .mnuEditDel.Enabled = blnIsnotEmpty And IsHaveRight
        .mnuEditInActive.Checked = False
        .mnuEditInActive.Enabled = blnIsnotEmpty And IsHaveRight
        .mnuEditShowAll.Checked = chkShowAll.Value
        .mnuEditShowAll.Enabled = True
        .mnuEditUse.Enabled = blnIsnotEmpty
        .mnuEditColumn.Enabled = True
        .mnuEditFilter.Enabled = True
        .mnuEditSearch.Enabled = True
        .mnuFilePrint.Enabled = True
        .mnuFilePrintSetup.Enabled = True
        '.mnuAccountVoucher.Enabled = blnIsnotEmpty
        .mnuReportQuick.Enabled = blnIsnotEmpty
        .mnuToolRefresh.Enabled = True
    End With
    
    If msgTerm.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 控件
    With msgTerm
        .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
    cmdVoucherType(0).top = Me.ScaleHeight - cmdVoucherType(0).Height - ListFormBottom
    cmdVoucherType(1).top = cmdVoucherType(0).top
    chkShowAll.top = cmdVoucherType(0).top
    chkShowAll.Left = Me.ScaleWidth - chkShowAll.width - ListFormBottom
End Sub

Private Sub cmdVoucherType_Click(Index As Integer)
    Select Case Index
        Case 0
             MakeListEditMenu
             PopupMenu frmMain.mnuListEdit, , cmdVoucherType(0).Left, cmdVoucherType(0).top + cmdVoucherType(0).Height
       Case 1
            MakeListReportMenu
            PopupMenu frmMain.mnuListReport, , cmdVoucherType(1).Left, cmdVoucherType(1).top + cmdVoucherType(1).Height
    End Select
End Sub

'
'窗体 Form 控件
'
Private Sub Form_Load()
    Dim i As Integer
    Dim intSortCol As Integer
    On Error GoTo ErrHandle
    '付款条件列表窗体初始化
    Debug.Print "Load Start: ", Timer
    Set mclsList = New list
    mclsList.FlexNoChange = True
    mclsList.FindNoChange = True
    Set mclsList.FlexGrid = msgTerm
    Set mclsList.FindKind = cboFindKind
    Set mclsList.Find = txtfind
    Set mclsList.Again = cmdAgain
    mclsList.ListSet.ViewId = intViewID
    mclsList.InitFlexGrid
    If GetList.RecordCount = 0 Then
        frmInitVoucherTypeCard.Show vbModal
    End If
'    Me.Hide
'    Me.Left = -30000
    MsgForm.PleaseWait
    Me.HelpContextID = 30038
    Set datTerm.Recordset = GetList()
    If Not datTerm.Recordset.EOF Then datTerm.Recordset.MoveLast
    datTerm.Recordset.Close
    'Set datTerm.Recordset = Nothing
    mclsList.SetFlexGrid
    mclsList.InitcboFindKind
    mclsList.FlexNoChange = False
    mclsList.FindNoChange = False
     
  
    With msgTerm
        If .Rows > 1 Then msgTerm.Row = 1
        .col = 0
        .ColSel = .Cols - 1
    End With
    Debug.Print "Load End: ", Timer
    mclsList.DoShowAll False
    UpdateMenuStatus
    '设置钩子对象
    Set mclsSubClass = New SubClass32.SubClass
    mclsSubClass.hwnd = msgTerm.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
    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 mIsShowCard Then
        MsgBox "请先关闭凭证类型卡片！", vbExclamation
        Cancel = True
'        frmVoucherTypeListCard.Show
'        frmVoucherTypeListCard.ZOrder 0
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
'    If mIsShowCard Then Unload frmVoucherTypeListCard
    mclsList.SaveListSet
    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)
    If KeyAscii = vbKeyEscape Then
        Unload Me
    End If
End Sub
Private Sub Form_Activate()
    mclsMainControl_ChildActive
    gclsSys.CurrFormName = Me.hwnd
    'msgTerm.SetFocus
    msgTerm.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()
   msgTerm.Redraw = False
    mclsList.DoShowAll chkShowAll.Value
    msgTerm.Redraw = True
    'cboFindKind_Click
    UpdateMenuStatus
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 msgTerm
        .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 msgTerm.Rows > 1 Then
        If txtfind.Text = strFind Then
            txtFind_Change
        Else
            txtfind.Text = strFind
        End If
    End If
    msgTerm.Redraw = True
End Sub

Private Sub mclsMainControl_ChildActive()
    Dim vntMessage As Variant
    gclsSys.CurrFormName = Me.hwnd
    '响应消息
    For Each vntMessage In mclsMainControl.Messages
        If vntMessage = Message.msgVoucherType Then '接收到付款条件改变消息
            mclsMainControl_ToolRefresh
            mclsMainControl.Messages.Remove CStr(vntMessage) '清除付款条件改变消息
        End If
    Next
    mclsMainControl.Messages.Clear
    UpdateMenuStatus
End Sub

Private Sub mclsMainControl_FilePrintSetup()
    Dim MyPrintSet As PrintClass
    Set MyPrintSet = New PrintClass
    MyPrintSet.PrintSetUp gclsBase.BaseDB, mclsList.FlexGrid, , , , 30, " " & Chr(1) & gclsBase.BaseName & Chr(1) & gclsBase.OperatorName
    Set MyPrintSet = Nothing
End Sub

Private Sub mclsMainControl_ListReportMenu(ByVal intIndex As Integer)
    Select Case intIndex
        Case 0
            'VoucherTable
      '  Case 1
           ' VoucherTotail
       ' Case 2
            Report.ShowListReport 318, 358
    End Select
End Sub

Private Sub mclsSubClassForm_WndProc(Msg As Long, wParam As Long, lParam As Long, Result As Long)
    Dim MinMax As MINMAXINFO

    If Msg = WM_GETMINMAXINFO Then
        CopyMemory MinMax, ByVal lParam, Len(MinMax)
        
        MinMax.ptMinTrackSize.X = 430
        MinMax.ptMinTrackSize.y = 250
        
        CopyMemory ByVal lParam, MinMax, Len(MinMax)
        Result = 0
    End If
End Sub

'
'查找内容 TextBox 控件
'
Private Sub txtFind_Change()
      mclsList.TextFind txtfind.Text
End Sub

Private Sub txtFind_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim intSelLen As Integer
    If KeyCode = 8 Then
        intSelLen = txtfind.SelLength
        If txtfind.SelStart > 0 Then txtfind.SelStart = txtfind.SelStart - 1
        txtfind.SelLength = intSelLen + 1
    End If
End Sub
'
' FLEXGRID控件
'
'双击FLEXGRID调用卡片
Private Sub msgTerm_DblClick()
    If msgTerm.MouseRow > 0 And msgTerm.ColSel > 0 And msgTerm.MouseCol > 1 And frmMain.mnuEditEdit.Enabled Then
        mclsMainControl_EditEdit
    End If
End Sub

'单击FLEXGRID停用列,停用或启用当前记录
Private Sub msgTerm_MouseDown(Button As Integer, Shift As Integer, X As Single, y As Single)
    Dim blnCancel As Boolean
    
    With msgTerm
        If Button = vbLeftButton Then
            If chkShowAll.Value = 1 And .ColSel > 0 Then
                If X > .ColPos(1) And X < .ColPos(2) Then
                    .MousePointer = flexHourglass
                    mclsMainControl_EditInActive
                    .MousePointer = flexDefault
                End If
            End If
        Else
            Form_MouseDown Button, Shift, X, y
        End If
    End With
End Sub

'鼠标左键弹起时，更新菜单
Private Sub msgTerm_MouseUp(Button As Integer, Shift As Integer, X As Single, y As Single)
   With msgTerm
        If Button = vbLeftButton Then
            If chkShowAll.Value = 1 And .ColSel > 0 And .MouseRow > 0 And .Row > 0 Then
                If X > .ColPos(1) And X < .ColPos(2) Then
                    mclsMainControl_EditInActive
                End If
            End If
            UpdateMenuStatus
        End If
    End With
End Sub

'
'响应主控对象事件
'

'编辑卡片
Private Sub mclsMainControl_EditEdit()
    Dim lngID As Long