frmlistvoucher.frm

金算盘软件代码

        theEditForm.ShowAOldBill (lngVoucherID)  '调用接口
    Else
        theEditForm.ShowAOldBill (lngVoucherID) '调用接口
        mIsShowEdit = True
    End If
    Me.Enabled = True
End Sub

Private Sub mclsMainControl_EditFilter()
      '筛选
    Dim blnFlage As Boolean
    Dim strOld As String
    strOld = txtFind.Text
    With mclsList
        If .ListSet.ListID < 1 Then
           .ListSet.SaveList
           DefaultCurrentDate .ListSet.ListID, 9975
        End If
        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()
    Dim lngVoucherID As Long
    Dim CancelID As Long
    Dim theRow As Long
    Dim strFlag As String
    Dim i As Long
    'If grdList.TextMatrix(grdList.Row, 1) = "√" Then Exit Sub
    If gclsBase.PeriodClosed(gclsBase.BaseDate) Then
       ShowMsg Me.hWnd, "当前会计期间已经结帐，不能再作废凭证！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
       Exit Sub
    End If
    
    lngVoucherID = GetlngVoucherID()
    If lngVoucherID = -1 Then Exit Sub
    If Not mclsVoucher.GetAllID(lngVoucherID) Then Exit Sub
    If gclsBase.OperatorID <> mclsVoucher.oldlngOperatorID Then
        cMsgBox "不能作废由他人制作的凭证！"
        Exit Sub
    End If
    If Not mclsVoucher.DeleteVoucher(lngVoucherID, False, strVoucher, , , True) Then Exit Sub
    '在非全部显示模式下，作废某条记录后，应将该记录隐去
    
    ToolRefresh
End Sub

Private Sub mclsMainControl_EditNew()
    If gclsBase.PeriodClosed(gclsBase.BaseDate) Then
       ShowMsg Me.hWnd, "当前会计期间已经结帐，不能再增加凭证！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
       Exit Sub
    End If
    If mIsShowEdit Then
        theEditForm.ShowANewBill
    Else
        theEditForm.ShowANewBill
        mIsShowEdit = True
    End If
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_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, mintPrintID(mclsList.intTab), mstrPrintTitle(mclsList.intTab)
        myPrintclass.PrintNewList gclsBase.BaseDB, mclsList.Resultset(0), mclsList.DbTabCtrl.TableHandle, 50, "记帐凭证列表" & Chr(1) & gclsBase.BaseName & Chr(1) & gclsBase.OperatorName
     .DbTabCtrl.CellFormula(0, .SortCol + 1) = .DbTabCtrl.CellFormula(0, .SortCol + 1) & strSortChar
    End With
    Set myPrintclass = Nothing
End Sub

Private Sub mclsMainControl_FilePrintReceipt()
    frmPrintReceipt.ShowfrmPrintReceipt 29
    Me.Refresh
End Sub

Private Sub mclsMainControl_FilePrintSetup()
    Dim MyPrintSet As PrintClass
    Set MyPrintSet = New PrintClass
    MyPrintSet.PrintNewSetUp gclsBase.BaseDB, mclsList.DbTabCtrl.TableHandle, , , , 50, "记帐凭证列表" & 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:
         Report.ShowBalance 1783, 680
    Case 1:
         Report.ShowBalance 1483, 680
    End Select
End Sub

Private Sub mclsMainControl_ToolRefresh()
    Me.MousePointer = vbHourglass
    'ToolRefresh
    RefreshRecList
    Me.MousePointer = vbDefault
End Sub

'Private Sub MyConnect_QueryComplete(ByVal Query As RDO.rdoQuery, ByVal ErrorOccurred As Boolean)
'    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 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
        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_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 .DbTabCtrl.Row < .DbTabCtrl.Rows Then
                .Resultset(.intTab).AbsolutePosition = .DbTabCtrl.Row '- 1
        Else
            .DbTabCtrl.Row = .DbTabCtrl.Rows - 1
                .Resultset(.intTab).AbsolutePosition = .DbTabCtrl.Row '- 1
        End If
            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
    End If
    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 '双击排序
'            cboFindKind.Text = .CellFormula(0, lngY)
'        End If
        If lngY < 2 Then Exit Sub
        If .CellFormula(0, lngY) <> "" Then
                If lngY > cboFindKind.ListCount + 1 Then Exit Sub
                If lngY - 1 <> mclsList.SortCol Then
                    .CellFormula(0, mclsList.SortCol + 1) = Left(.CellFormula(0, mclsList.SortCol + 1), Len(.CellFormula(0, mclsList.SortCol + 1)) - 1)
                    On Error Resume Next
                    cboFindKind.Text = .CellFormula(0, lngY)
                    On Error GoTo 0
                Else
                    On Error Resume Next
                    cboFindKind.Text = Left(.CellFormula(0, mclsList.SortCol + 1), Len(.CellFormula(0, mclsList.SortCol + 1)) - 1)
                    On Error GoTo 0
                End If
        End If
    End If
    End With
End Sub

Private Sub pctDataGrid_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbRightButton Then
        Form_MouseDown Button, Shift, x, y
    End If
End Sub

Private Sub pctDataGrid_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim lngX As Long
    Dim lngY As Integer
    
    With mclsList.DbTabCtrl
        .MouseCell lngX, lngY
    If lngY = 1 Then
           pctDataGrid.MousePointer = vbCustom
    Else
         pctDataGrid.MousePointer = vbDefault
    End If
    End With
End Sub

Private Sub pctDataGrid_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim lngX As Long
    Dim lngY As Integer
    With mclsList.DbTabCtrl
        If Button = vbLeftButton Then
            If chkShowall.Value = 1 And .Row < .Rows And .Row > 0 Then
                .MouseCell lngX, lngY
                If lngX <> 0 And lngY = 1 Then
                    pctDataGrid.MousePointer = flexHourglass
                    mclsMainControl_EditInActive
                    pctDataGrid.MousePointer = flexDefault
                End If
            End If
            UpdateEditMenuStatus
        ElseIf Button = vbRightButton Then
            Form_MouseDown Button, Shift, x, y
        End If
  End With
End Sub


'根新编辑菜单
Private Sub UpdateEditMenuStatus()
    Dim i As Integer
    Dim lngVoucherID As Long
    Dim blnIsnotEmpty As Boolean
    Dim blnFindNoChange As Boolean
    Dim blnHaveRows As Boolean

On Error Resume Next
    
    If mclsList.DbTabCtrl.Rows = 1 Then
        blnHaveRows = False
    Else
        blnHaveRows = True
    End If
    If mclsList.DbTabCtrl.Row > 0 And mclsList.DbTabCtrl.Row <= mclsList.TotalRow(mclsList.intTab) Then
        blnIsnotEmpty = True
    Else
        blnIsnotEmpty = False
    End If
    
    If Not blnMenuBuilded Then
        MakeListEditMenu
    End If
    With frmMain
                        
        '注意：《修改》《删除》《作废》永远可见
        
'        .mnuEditCopy.Enabled = blnIsnotEmpty
        .mnuEditEdit.Enabled = blnIsnotEmpty And blnEdit
        .mnuEditNew.Enabled = blnEdit
        .mnuEditDel.Enabled = blnIsnotEmpty And blnEdit ' And blnEdit
        
        .mnuEditInActive.Checked = False
        .mnuEditInActive.Enabled = blnIsnotEmpty And blnEdit  'And Trim(grdList.TextMatrix(grdList.Row, 1)) = ""
        If chkShowall.Value = 1 Then
            .mnuEditShowAll.Checked = True
        Else
            .mnuEditShowAll.Checked = False
        End If
        If chkShowall.Enabled = True Then
            .mnuEditShowAll.Enabled = True
        Else
            .mnuEditShowAll.Enabled = False
        End If
        .mnuEditColumn.Enabled = True
        .mnuEditFilter.Enabled = True
        .mnuFilePrint.Enabled = True
        .mnuFilePrintReceipt.Enabled = True
        .mnuReportQuick.Enabled = blnIsnotEmpty
        .mnuToolRefresh.Enabled = True
        
        If mclsVoucher.CheckRights Then
            .mnuListEditMenu(9).Enabled = blnIsnotEmpty ''复核/取消复核
            .mnuListEditMenu(12).Enabled = blnHaveRows  '多张复核
            .mnuListEditMenu(13).Enabled = blnHaveRows  '多张取消
        Else
            .mnuListEditMenu(9).Enabled = False
            .mnuListEditMenu(12).Enabled = False
            .mnuListEditMenu(13).Enabled = False
        End If
        If mclsVoucher.PostRights Then
            .mnuListEditMenu(10).Enabled = blnIsnotEmpty ''记帐/取消记帐
            .mnuListEditMenu(15).Enabled = blnHaveRows ''多张记帐
            .mnuListEditMenu(16).Enabled = blnHaveRows ''多张取消
        Else
            .mnuListEditMenu(10).Enabled = False ''记帐/取消记帐
            .mnuListEditMenu(15).Enabled = False ''多张记帐
            .mnuListEditMenu(16).Enabled = False ''多张取消
        End If
        
        .mnuEditEdit.Caption = "修改(&E)"
        .mnuEditNew.Caption = "新增(&N)"
        .mnuEditDel.Caption = "删除(&D)"
        
        .mnuEditInActive.Caption = "作废(&H)"
        .mnuEditShowAll.Caption = "全部显示(&W)"
        .mnuEditInActive.Visible = False