frmlistvoucher.frm

金算盘软件代码

    mclsList.DbTabCtrl.Clear
    MakeListSql 0
    mclsList.SetGridFormate
    'SetFormation
    UpdateEditMenuStatus
End Function
'Public Function AsnToolRefresh() As Boolean
'    With mclsList
'    .DbTabCtrl.Clear
'    Set .Resultset(.intTab) = mResultsetValue
'    If Not mResultsetNo.EOF Then .TotalRow(.intTab) = mResultsetNo.rdoColumns(0)
'    .intTab = .intTab
'    .SetGridFormate
'    End With
'    UpdateEditMenuStatus
'End Function
'重新构造数据
Private Function ReMakeData()
     With mclsList
        .ListSet.ViewId = mintViewId
        intcboFindKind
        mclsList.DbTabCtrl.Clear
        MakeListSql 0
        mclsList.SetGridFormate
        'SetFormation
    End With
    UpdateEditMenuStatus
End Function

Private Sub RedrawForm()
    On Error Resume Next
    With pctDataGrid
        .top = 500
        .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
    cmdEAR(0).top = Me.ScaleHeight - cmdEAR(0).Height - ListFormBottom
    cmdEAR(1).top = cmdEAR(0).top
    chkShowall.top = cmdEAR(0).top
    chkShowall.Left = Me.ScaleWidth - chkShowall.width - ListFormBottom
End Sub

Private Sub cboFindKind_Click()
    Dim intCount As Integer
    Dim blnFindKindIsChange As Boolean
    Dim strOldText As String
    
    blnFindKindIsChange = False
    strOldText = txtFind.Text
    With mclsList.ListSet
        For intCount = 1 To .Columns
            If .ColumnIsFind(intCount) Then
                If .ColumnDesc(intCount) = cboFindKind.Text Then
                    If mclsList.SortCol <> intCount Then
                        .ColumnOrderType(mclsList.SortCol) = 0
                         .ColumnOrderType(intCount) = 1
                         mclsList.SortCol = intCount
                         mclsList.FindColName = .ColumnDesc(intCount)
                         blnFindKindIsChange = True
                         Exit For
                    End If
                End If
            End If
        Next
    End With
    If blnFindKindIsChange And mIsFind Then
        ToolRefresh 'ReSortGrid '重新排序查找
        'txtFind.Text = strOldText
    With mclsList
        If .DbTabCtrl.Row < .DbTabCtrl.Rows Then
            If Not .Resultset(.intTab).EOF And Not .Resultset(.intTab).BOF Then
                '.Resultset(.intTab).MoveFirst
                '.Resultset(.intTab).Move .DbTabCtrl.Row - 1, 1
                .Resultset(.intTab).AbsolutePosition = .DbTabCtrl.Row
            End If
        Else
            .DbTabCtrl.Row = .DbTabCtrl.Rows - 1
            If Not mclsList.Resultset(.intTab).EOF And Not mclsList.Resultset(.intTab).BOF Then
                '.Resultset(.intTab).MoveFirst
                '.Resultset(.intTab).Move .DbTabCtrl.Row - 1, 1
                .Resultset(.intTab).AbsolutePosition = .DbTabCtrl.Row
            End If
        End If
    
        If Not .Resultset(.intTab).EOF And Not .Resultset(.intTab).BOF Then txtFind.Text = IIf(IsNull(.Resultset(.intTab).rdoColumns(.SortCol + 1).Value), "", .Resultset(.intTab).rdoColumns(.SortCol + 1).Value)
    End With
    End If
End Sub

Private Sub chkShowAll_Click()
    'mclsList.DoShowAll chkShowall.Value
    Debug.Print "Chk1:" & Timer
    mclsList.ShowAll = Not mclsList.ShowAll
    Debug.Print "Chk2:" & Timer
    ToolRefresh
    Debug.Print "Chk3:" & Timer
    frmMain.mnuEditShowAll.Checked = Not frmMain.mnuEditShowAll.Checked
    UpdateEditMenuStatus
    Debug.Print "Chk4:" & Timer
End Sub

Private Sub cmdAgain_Click()
    With mclsList.DbTabCtrl
'        If .CellValue(.Row + 1, mclsList.SortCol + 1) Like txtFind.Text & "*" Then
'            .Row = .Row + 1
'        End If
        If .CellValue(.Row + 1, mclsList.SortCol + 1) Like txtFind.Text & "*" Or Trim(.CellValue(.Row + 1, mclsList.SortCol + 1)) = "" 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
            MakeListEditMenu
            UpdateEditMenuStatus
            PopupMenu frmMain.mnuListEdit, , cmdEAR(0).Left, cmdEAR(0).top + cmdEAR(0).Height
        Case 1
            MakeListReportMenu
            PopupMenu frmMain.mnuListReport, , cmdEAR(1).Left, cmdEAR(1).top + cmdEAR(1).Height
    End Select
    
End Sub

Private Sub Form_Activate()
     On Error Resume Next
    SetHelpID Me.HelpContextID
    mclsMainControl_ChildActive
    gclsSys.CurrFormName = Me.hWnd
    ComPleteLoad = ComPleteLoad + 1
    UpdateEditMenuStatus
    If Me.WindowState = 1 Then Me.WindowState = 0
    pctDataGrid.SetFocus
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
    Debug.Print "LoadStart:" & Timer
    
   ' Set MyConnect = gclsBase.BaseDB
    
    MsgForm.PleaseWait
    ComPleteLoad = 0
    Me.HelpContextID = 60014
    blnMenuBuilded = False
    blnEdit = IsCanDo(frmRightsID.frmVoucherListID, gclsBase.OperatorID) '判断有无编辑权
    Me.Caption = "记帐凭证列表"
    Set pctDataGrid.MouseIcon = GetFormResPicture(101, vbResCursor)
    Set mclsVoucher = New clsVoucherMethod
    mclsVoucher.SethWnd Me.hWnd
    Set theEditForm = FrmVoucher
    Set mclsList = New ListGrid
    'Set mclsList.Find = txtFind
    mclsList.Thwnd = pctDataGrid.hWnd
    Debug.Print "SetViewIDStart:" & Timer
    mclsList.ListSet.ViewId = mintViewId
    Debug.Print "SetViewIDEnd:" & Timer
    mIsFind = False
    intcboFindKind
    mIsFind = True
   
    mclsList.intTabs = 1
    mclsList.DbTabCtrl.Clear
    MakeListSql 0
    Debug.Print "SetGridFormatStart:" & Timer
    mclsList.SetGridFormate
    Debug.Print "SetGridFormatEnd:" & Timer
    UpdateEditMenuStatus
    Set mclsMainControl = gclsSys.MainControls.Add(Me)
    Unload MsgForm
    ComPleteLoad = ComPleteLoad + 1
    Debug.Print "LoadEnd:" & Timer
     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
        UpdateEditMenuStatus
        PopupMenu frmMain.mnuListEdit
    End If
End Sub

Private Sub Form_Paint()
'    If mintPage > 1 Then
'        DrawInSertLine Me.hwnd, ListFormLeft, 500, Me.width - 2 * (ListFormLeft + ListFormRight), 500
'    End If
'    If Not mResultsetNo.StillExecuting And Not blnNumberFinish Then mRows = mResultsetNo.rdoColumns(0)
'    If Not mResultsetValue.StillExecuting And Not blnValueFinish Then
'        '"个性"
'        AsnToolRefresh
'    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If blnChange = True Then Cancel = 1
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)
    blnMenuBuilded = False
    If mclsList.ListSet.ListID < 1 Then
       mclsList.SaveListSet
       DefaultCurrentDate mclsList.ListSet.ListID, 9975
    Else
       mclsList.SaveListSet
    End If
    Set mclsVoucher = Nothing
    Set theEditForm = Nothing
    Set mclsList = Nothing
    gclsSys.MainControls.Remove Me
    
'    mV_Connect.Close
'    Set mV_Connect = Nothing
    Set mclsMainControl = Nothing
End Sub

Private Sub mclsMainControl_ChildActive()
    Dim vntMessage As Variant
    SetHelpID Me.HelpContextID
    gclsSys.CurrFormName = Me.hWnd
    For Each vntMessage In mclsMainControl.Messages
        If vntMessage = Message.msgReceipt41 Or vntMessage = Message.msgTrans Or vntMessage = Message.msgAccount Then
            ToolRefresh
            mclsMainControl.Messages.Remove CStr(vntMessage) '清除消息
        End If
    Next
    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) Then
            ReMakeData
        End If
        If .SortCol = lngSortCol Then txtFind.Text = strOld
    End With
End Sub

Private Sub mclsMainControl_EditDel()
    Dim lngVoucherID As Long
    Dim i As Long
    Dim intTop As Long
    Dim lngVoucherID_Cancel As Long
    
    lngVoucherID = GetlngVoucherID
    If lngVoucherID = -1 Then Exit Sub
    lngVoucherID_Cancel = 0
    If Not mclsVoucher.DeleteVoucher(lngVoucherID, , strVoucher, lngVoucherID_Cancel) Then Exit Sub
    ToolRefresh
End Sub

Private Sub mclsMainControl_EditEdit()
    Dim lngVoucherID As Long
    Me.Enabled = False
    lngVoucherID = GetlngVoucherID()
    If lngVoucherID = -1 Then Exit Sub
    If mIsShowEdit Then