frmalisttemplate.frm

金算盘软件代码

'下一个
Private Sub cmdAgain_Click()
    With mclsList.DbTabCtrl
        If .CellValue(.Row + 1, mclsList.SortCol + 1) Like txtFind.Text & "*" Then
            If .Row < .Rows Then
                .Row = .Row + 1
            Else
                cmdAgain.Enabled = False
            End If
        Else
            cmdAgain.Enabled = False
        End If
    End With
End Sub
'控件处理
Private Sub cmdEAR_Click(Index As Integer)
    Select Case Index
        Case 0
            UpdateEditMenuStatus
            MakeListEditMenu
            If blnIsDealMenu Then RaiseEvent ListPopBefore(mblnNew, mblnEdit)
            PopupMenu frmMain.mnuListEdit, , cmdEAR(0).Left, cmdEAR(0).top + cmdEAR(0).Height
            If blnIsDealMenu Then RaiseEvent ListPopAfter(mblnNew, mblnEdit)
            mclsList.Resultset(mclsList.intTab).Requery
        Case 1
            MakeListReportMenu
            PopupMenu frmMain.mnuListReport, , cmdEAR(1).Left, cmdEAR(1).top + cmdEAR(1).Height
        Case 2
            RaiseEvent cmdMessage(Index)
        Case 3
            RaiseEvent cmdMessage(Index)
    End Select
    
End Sub

Private Sub Form_Activate()
     On Error Resume Next
    SetHelpID Me.HelpContextID
    mclsList.Resultset(mclsList.intTab).Requery
    mclsMainControl_ChildActive
    gclsSys.CurrFormName = Me.hwnd
    If ComPleteLoad > 1 Then
        'ToolRefresh
    End If
    ComPleteLoad = ComPleteLoad + 1
    pctDataGrid.SetFocus
    If blnIsItem Then
    cmdEAR(2).Enabled = IsCanDo(225, gclsBase.OperatorID)
    End If
    UpdateEditMenuStatus
    If Me.WindowState = 1 Then Me.WindowState = 0
End Sub

Private Sub Form_Deactivate()
    frmMain.SetEditUnEnabled
    If ComPleteLoad > 3 Then
        ComPleteLoad = ComPleteLoad - 1
    Else
        ComPleteLoad = ComPleteLoad + 1
    End If
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_Load()
    Dim i As Integer
    On Error GoTo ErrHandle
    
'    Dim strConnect As String
'    Set m_Connect = New ADODB.Connection
'    strConnect = "PWD=" & strBasePassWord & ";DBQ=" & gclsBase.BaseFile & ";DefaultDir=;Driver=" _
'        & "{Microsoft Access Driver (*.mdb)};"
'    m_Connect.Open strConnect
    
    MsgForm.PleaseWait
    ComPleteLoad = 0
    Me.HelpContextID = mHelpID
    Me.Caption = mTitle
    Set mclsList = New ListGrid
    'Set mclsList.Find = txtFind
   ' Set mclsList.DataGrid = pctDataGrid
   mclsList.Thwnd = pctDataGrid.hwnd
    Set pctDataGrid.MouseIcon = GetFormResPicture(101, vbResCursor)

    If blnReceptionList And blnIsHavingReport Then
        cmdEAR(1).Visible = True
    Else
        cmdEAR(1).Visible = False
    End If
    
    Debug.Print "SetViewIDStart: " & Timer
    mclsList.ListSet.ViewId = mintViewId(0)
    mclsList.ListSet.FormatSelect = False
     Debug.Print "SetViewIDEnd: " & Timer
    If blnReceptionList And mclsList.ListSet.ListID < 1 Then
        Select Case mintViewId(0)
            Case 529, 530, 531, 532, 533, 534, 535
            Case Else
                mclsList.ListSet.SaveList
                If Not blnunDefaultWhere Then SetDefaultWhere mintViewId(0), mclsList.ListSet.ListID
                mclsList.ListSet.RefreshWhere
        End Select
    End If
     Debug.Print "3: " & Timer
    mclsList.intTabs = mTabs
     Debug.Print "4: " & Timer
    IsFind = False
    intcboFindKind
    IsFind = True
     Debug.Print "5: " & Timer
    If mTabs > 1 Then
        sstPages.Visible = True
        sstPages.Tabs = mTabs
        For i = 0 To mTabs - 1
            sstPages.TabCaption(i) = mTabCaption(i)
        Next
    Else
        sstPages.Visible = False
    End If
     Debug.Print "6: " & Timer
    If mTabs > 1 Then
        If sstPages.Tab <> 0 Then
            sstPages.Tab = 0
        Else
            sstPages_Click 0
        End If
    Else
        mclsList.DbTabCtrl.Clear
        MakeListSql 0
        mclsList.SetGridFormate
        UpdateEditMenuStatus
    End If
     Debug.Print "LoadEnd: " & Timer
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
    Unload MsgForm
    ComPleteLoad = ComPleteLoad + 1
     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
        UpdateEditMenuStatus
        MakeListEditMenu
        If blnIsDealMenu Then RaiseEvent ListPopBefore(mblnNew, mblnEdit)
            PopupMenu frmMain.mnuListEdit
        If blnIsDealMenu Then RaiseEvent ListPopAfter(mblnNew, mblnEdit)
        mclsList.Resultset(mclsList.intTab).Requery
    End If
End Sub

Private Sub Form_Paint()
    If mTabs > 1 Then
        DrawInSertLine Me.hwnd, ListFormLeft, 500, Me.width - 2 * (ListFormLeft + ListFormRight), 500
    End If
End Sub

Private Sub Form_Resize()
    If Me.WindowState = 1 Then Exit Sub
    If Me.WindowState = vbNormal Then
        If Me.width <= 5300 Then Me.width = 5300
        If Me.Height <= 3500 Then Me.Height = 3500
    End If
    RedrawForm
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Dim cTmpobject As Object
    Dim i As Integer
    For i = 0 To mTabs - 1
        mblnIsload(i) = False
    Next
    mclsList.SaveListSet
    gclsSys.MainControls.Remove Me
    Set mclsMainControl = Nothing
'    m_Connect.Close
'    Set m_Connect = Nothing
    
    'On Error Resume Next
     Set cTmpobject = gclsList.Item(strListType)
    Set cTmpobject = Nothing
    Set mclsList = Nothing
    gclsList.Remove strListType
End Sub

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

Private Sub mclsMainControl_ChildActive()
    SetHelpID Me.HelpContextID
    gclsSys.CurrFormName = Me.hwnd
    RaiseEvent ListChildActive
    UpdateEditMenuStatus
End Sub

Private Sub mclsMainControl_EditColumn()
    Dim strOld As String
    Dim lngSortCol As Long
    
    strOld = txtFind.Text
    
    With mclsList
        lngSortCol = .SortCol
        If mclsList.ListSet.ShowListSet(mintViewId(.intTab)) Then
            ReMakeData
        End If
        If .SortCol = lngSortCol Then txtFind.Text = strOld
    End With
End Sub

Private Sub mclsMainControl_EditDel()
    RaiseEvent ListDel
    mclsList.Resultset(mclsList.intTab).Requery
End Sub

Private Sub mclsMainControl_EditEdit()
    RaiseEvent ListEdite
    mclsList.Resultset(mclsList.intTab).Requery
End Sub

Private Sub mclsMainControl_EditFilter()
      '筛选
    Dim blnFlage As Boolean
    Dim strOld As String
    strOld = txtFind.Text
    With mclsList
        Debug.Print .ListSet.ViewId
        If .ListSet.ListID < 1 Then .SaveListSet '.ListSet.SaveList
        Filter.ShowFilter .ListSet.ListID, 1, , , , , blnFlage
        If Not blnFlage Then Exit Sub
        .ListSet.RefreshWhere
        '.SaveListSet
        ToolRefresh
        UpdateEditMenuStatus
        '初始化查找复合列表框
        txtFind.Text = strOld
    End With
End Sub

Private Sub mclsMainControl_EditInActive()
    'RaiseEvent ListInActive
    Dim blnSucess As Boolean
    Dim blnLevel As Boolean
    blnSucess = False '停用是否成功
    blnLevel = False '是否为层次编码（层次编码由用户刷新）
    RaiseEvent ListInActive(blnLevel, blnSucess)
    With mclsList.DbTabCtrl
    If Not blnLevel And blnSucess Then
         mclsList.DbTabCtrl.CellFormula(.Row, 1) = IIf(IsInActive, " ", "√")
    End If
'    If blnSucess Then
'        mclsList.DbTabCtrl.CellFormula(.Row, 1) = IIf(IsInActive, " ", "√")
'
'    End If
    mclsList.frmDoShowAll
    End With
End Sub

Private Sub mclsMainControl_EditNew()
    RaiseEvent ListNew
    mclsList.Resultset(mclsList.intTab).Requery
End Sub

Private Sub mclsMainControl_EditShowAll()
    frmMain.mnuEditShowAll.Checked = Not frmMain.mnuEditShowAll.Checked
    If chkShowall.Value = 0 Then
        chkShowall.Value = 1
    Else
        chkShowall.Value = 0
    End If
End Sub

Private Sub mclsMainControl_EditUse()
    RaiseEvent ListUsed
End Sub

Private Sub mclsMainControl_FilePrint()
    Dim myPrintclass As PrintClass
    Dim strSortChar As String
    Set myPrintclass = New PrintClass
    With mclsList
        strSortChar = Right(.DbTabCtrl.CellFormula(0, .SortCol + 1), 1)
        .DbTabCtrl.CellFormula(0, .SortCol + 1) = Left(.DbTabCtrl.CellFormula(0, .SortCol + 1), Len(.DbTabCtrl.CellFormula(0, .SortCol + 1)) - 1)
    myPrintclass.PrintNewList gclsBase.BaseDB, mclsList.Resultset(mclsList.intTab), mclsList.DbTabCtrl.TableHandle, mintPrintID(mclsList.intTab), mstrPrintTitle(mclsList.intTab)
     .DbTabCtrl.CellFormula(0, .SortCol + 1) = .DbTabCtrl.CellFormula(0, .SortCol + 1) & strSortChar
    End With
    Set myPrintclass = Nothing
End Sub

Private Sub mclsMainControl_FilePrintReceipt()
    RaiseEvent ListPrintReceipt
    Me.Refresh
End Sub

Private Sub mclsMainControl_FilePrintSetup()
    Dim MyPrintSet As PrintClass
    Set MyPrintSet = New PrintClass
    MyPrintSet.PrintNewSetUp gclsBase.BaseDB, mclsList.DbTabCtrl.TableHandle, , , , mintPrintID(mclsList.intTab), mstrPrintTitle(mclsList.intTab)
    Set MyPrintSet = Nothing
End Sub

Private Sub mclsMainControl_ListReportMenu(ByVal intIndex As Integer)
    If blnReceptionList And blnIsHavingReport Then
        RaiseEvent ListReorpt(intIndex)
    End If
End Sub

Private Sub mclsMainControl_ToolRefresh()
    Me.MousePointer = vbHourglass
    mclsList.SaveListSet
    ToolRefresh
    Me.MousePointer = vbDefault
End Sub

Private Sub pctDataGrid_Click()
     With mclsList
        If .DbTabCtrl.Row < .DbTabCtrl.Rows Then
            If .TotalRow(.intTab) > 0 Then .Resultset(.intTab).MoveFirst
            If .DbTabCtrl.Row - 1 <> 0 Then .Resultset(.intTab).AbsolutePosition = .DbTabCtrl.Row '- 1 'mResultset(mTab).Move .Row - 1, 1
        Else
            .DbTabCtrl.Row = .DbTabCtrl.Rows - 1
            If .TotalRow(.intTab) > 0 Then .Resultset(.intTab).MoveFirst
            If .DbTabCtrl.Row - 1 <> 0 Then .Resultset(.intTab).AbsolutePosition = .DbTabCtrl.Row '- 1 ' mResultset(mTab).Move .Row - 1, 1
        End If
        '.SetRow
        If Not .Resultset(.intTab).EOF And Not .Resultset(.intTab).BOF Then
        mblnIsFindTextChange = False
        txtFind.Text = IIf(IsNull(.Resultset(.intTab).rdoColumns(.SortCol + 1).Value), "", .Resultset(.intTab).rdoColumns(.SortCol + 1).Value)
        mblnIsFindTextChange = True
        End If
    End With
    Exit Sub
End Sub

Private Sub pctDataGrid_DblClick()
    Dim lngX As Long
    Dim lngY As Integer
    
    With mclsList.DbTabCtrl
        .MouseCell lngX, lngY
     If lngX > 0 And lngX < .Rows And frmMain.mnuEditEdit.Enabled Then
        mclsMainControl_EditEdit
     ElseIf lngX = 0 Then
       ' If .CellFormula(0, lngY) <> cboFindKind.Text Then '双击排序
           If lngY < 2 Then Exit Sub
           If .CellFormula(0, lngY) <> "" Then
                mclsList.SaveListSet
                If lngY - 1 <> mclsList.SortCol Then
                    .CellFormula(0, mclsList.SortCol + 1) = Left(.CellFormula(0, mclsList.SortCol + 1), Len(.CellFormula(0, mclsList.SortCol + 1)) - 1)
                    cboFindKind.Text = .CellFormula(0, lngY)
                Else
                    cboFindKind.Text = Left(.CellFormula(0, mclsList.SortCol + 1), Len(.CellFormula(0, mclsList.SortCol + 1)) - 1)
                End If
           End If
       ' End If
     End If
    End With
End Sub

Private Sub pctDataGrid_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 37 Or KeyCode = 38 Or KeyCode = 39 Or KeyCode = 40 Then
        With mclsList
        If .DbTabCtrl.Row = 0 Then
            .DbTabCtrl.Row = 1
            mclsList.SetRow
        End If
        If .TotalRow(.intTab) = 0 Then Exit Sub
        If .DbTabCtrl.Row < .DbTabCtrl.Rows Then
                .Resultset(.intTab).AbsolutePosition = .DbTabCtrl.Row '- 1
        Else
            .DbTabCtrl.Row = .DbTabCtrl.Rows - 1
                .Resultset(.intTab).AbsolutePosition = .DbTabCtrl.Row '- 1