frmfixedinit.frm

金算盘软件代码

            .mnuListEditMenu(1).Enabled = False
            .mnuListEditMenu(2).Enabled = False
            .mnuListEditMenu(4).Enabled = False
        End If
        .mnuListEditMenu(6).Enabled = True
        .mnuListEditMenu(7).Enabled = True
        .mnuListEditMenu(8).Enabled = True
        .mnuListEditMenu(10).Enabled = (msgGrid.Rows > 1)
        .mnuListEditMenu(11).Enabled = (msgGrid.Rows > 1)
        .SetToolBar
    End With
End Sub


'刷新MDI主窗体菜单
Private Sub RefreshMenu()
    With frmMain
        .mnuEditCopy.Enabled = False
        .mnuEditEdit.Enabled = False
        .mnuEditNew.Enabled = True
        .mnuEditDel.Enabled = False
        .mnuEditInActive.Enabled = False
        .mnuEditShowAll.Checked = False
        .mnuEditShowAll.Enabled = False
        .mnuEditUse.Enabled = False
        .mnuEditColumn.Enabled = True
        .mnuEditFilter.Enabled = True
        .mnuEditSearch.Enabled = True
        .mnuEditNotepad.Enabled = False
        .mnuEditShowList.Enabled = False
        .mnuEditUse.Enabled = False
        .mnuFilePrintSetup.Enabled = False
        .mnuFilePrint.Enabled = False
        .mnuFilePrintReceipt.Enabled = False
        .mnuToolRefresh.Enabled = True
        If msgGrid.Rows > 1 Then
            .mnuEditEdit.Enabled = True
            .mnuEditDel.Enabled = True
            .mnuFilePrint.Enabled = True
            .mnuFilePrintSetup.Enabled = True
            .mnuFilePrintReceipt.Enabled = True
        End If
        .SetToolBar
    End With
End Sub

'删除选中的固资变动资料
Private Function DeleteFix() As Boolean
    Dim strSql As String
    Dim recAlter As rdoResultset
    Dim recCard As rdoResultset
    Dim recVoucher As rdoResultset
    Dim lngLastFixedAlterID As Long
    Dim intYear As Integer
    Dim bytPeriod As Integer
    Dim lngAlterID As Long
    Dim lngCardID As Long
    Dim strDate As String
    
    With msgGrid
        strDate = gclsBase.BeginDate
        lngAlterID = GetValue(.Row, 1)
        lngCardID = GetValue(.Row, 2)
    End With
    If Not IsDate(strDate) Then
        Exit Function
    End If
    bytPeriod = gclsBase.PeriodOfDate(CDate(strDate))
    intYear = gclsBase.FYearOfDate(CDate(strDate))
    If gclsBase.PeriodClosed(strDate) Then
        ShowMsg hWnd, "启用期间已结帐，不能修改期初资料！", vbExclamation, Me.Caption
        Exit Function
    End If
    If PeriodDepection(intYear, bytPeriod, 0, False) Then
        NextPeriod intYear, bytPeriod, 1
        ShowMsg hWnd, "固定资产已提过折旧，不能删除！", vbExclamation, Me.Caption
        Exit Function
    End If
    
    strSql = "SELECT * FROM FixedAlter WHERE lngLastFixedAlterID=" & lngAlterID
    Set recAlter = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recAlter.EOF Then
        ShowMsg hWnd, "该固定资产在以后期间又发生过变动，不能删除！", vbExclamation, Me.Caption
        recAlter.Close
        Exit Function
    End If
    recAlter.Close
    
    If ShowMsg(hWnd, "你是否确定要删除该变动资料?", vbQuestion + vbYesNo + vbDefaultButton2, Caption) <> vbYes Then
        Exit Function
    End If
    
    On Error GoTo HandleErr
    gclsBase.BaseWorkSpace.BeginTrans
    
    strSql = "SELECT * FROM FixedAlter WHERE lngFixedAlterID=" & lngAlterID
    Set recAlter = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recAlter.EOF Then
        lngLastFixedAlterID = recAlter!lngLastFixedAlterID
        strSql = "DELETE FROM FixedAlter WHERE lngFixedAlterID=" & lngAlterID
        If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
        strSql = "DELETE FROM FixedDepartment WHERE lngFixedAlterID=" & lngAlterID
        If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
        strSql = "DELETE FROM FixedCost WHERE lngFixedAlterID=" & lngAlterID
        If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
        strSql = "DELETE FROM FixedAccount WHERE lngFixedAlterID=" & lngAlterID
        If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
        strSql = "SELECT * FROM FixedAlter WHERE lngFixedCardID=" & lngCardID _
            & " AND TO_DATE(strDate,'YYYY-MM-DD')>TO_DATE('" & strDate & "','YYYY-MM-DD') AND lngFixedAlterID>" & lngAlterID & " ORDER BY TO_DATE(strDate,'YYYY-MM-DD')"
        Set recAlter = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If lngLastFixedAlterID = 0 Then
            If Not recAlter.EOF Then
                '第一条变动记录删除
                strSql = "UPDATE FixedAlter SET lngLastFixedAlterID=0 WHERE lngFixedAlterID=" & recAlter!lngFixedAlterID
                If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
                strSql = "UPDATE FixedCard SET lngCreateFixedAlterID=" & recAlter!lngFixedAlterID _
                    & ",lngRecentFixedAlterID=" & recAlter!lngFixedAlterID _
                    & " WHERE lngFixedCardID=" & lngCardID
                If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
                strSql = "DELETE FROM FixedBalance WHERE lngFixedCardID=" & lngCardID _
                    & " AND intYear=" & intYear & " AND bytPeriod=" & bytPeriod
                If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
                UpdateAfterFixedAlter recAlter!lngFixedAlterID
            Else
                '唯一一条变动记录删除
                strSql = "DELETE FROM FixedCard WHERE lngFixedCardID=" & lngCardID
                If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
                strSql = "DELETE FROM FixedBalance WHERE lngFixedCardID=" & lngCardID
                If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
                strSql = "DELETE FROM FixedAlter WHERE lngFixedCardID=" & lngCardID
                If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
            End If
        Else
            If Not recAlter.EOF Then
                '中间变动记录删除
                strSql = "UPDATE FixedAlter SET lngLastFixedAlterID=" & lngLastFixedAlterID _
                    & " WHERE lngFixedAlterID=" & recAlter!lngFixedAlterID
                If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
                strSql = "DELETE FROM FixedBalance WHERE lngFixedCardID=" & lngCardID _
                    & " AND intYear=" & intYear & " AND bytPeriod=" & bytPeriod
                If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
                UpdateAfterFixedAlter lngLastFixedAlterID
            Else
                '最后变动记录删除
                strSql = "UPDATE FixedCard SET lngRecentFixedAlterID=" & lngLastFixedAlterID _
                    & " WHERE lngFixedCardID=" & lngCardID
                If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
                strSql = "SELECT * FROM FixedAlter WHERE lngFixedAlterID=" & lngLastFixedAlterID
                Set recAlter = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                strSql = "DELETE FROM FixedBalance WHERE lngFixedCardID=" & lngCardID _
                    & " AND intYear * 100 + bytPeriod>" & CLng(intYear) * 100 + bytPeriod
                If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
                strSql = "UPDATE FixedBalance SET dblDebitAmount=0,dblCreditAmount=0,dblAlterDeprection=0," _
                    & "dblCalcAmount=Abs(dblCalcAmount),dblCalcDeprection=Abs(dblCalcDeprection) " _
                    & "WHERE lngFixedCardID=" & lngCardID & " AND intYear=" & intYear _
                    & " AND bytPeriod=" & bytPeriod
                If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
                UpdateAfterFixedAlter lngLastFixedAlterID
            End If
        End If
    End If
    recAlter.Close
    gclsBase.BaseWorkSpace.CommitTrans
    gclsSys.SendMessage Me.hWnd, msgFixed
    DeleteFix = True
    Exit Function
    
HandleErr:
    gclsBase.BaseWorkSpace.RollBacktrans
    ShowMsg hWnd, "程序出错：" & Err.Description, vbOKOnly + vbCritical, Caption
End Function

'筛选
Private Sub SelWithFilter()
    Dim blnOK As Boolean
    
    If mclsList.ListSet.ListID = 0 Then
        mclsList.ListSet.SaveList
    End If
    Filter.ShowFilter mclsList.ListSet.ListID, 1, , , , , blnOK
    If blnOK Then
        RefreshAlterGrid
    End If
End Sub

Private Function GetValue(lngRow As Long, intCol As Integer, Optional strType As String = "Double") As Variant
    GetValue = GetGridValue(lngRow, intCol, strType, msgGrid)
End Function

Private Sub RefreshAlterGrid()
    msgGrid.SelectionMode = flexSelectionByRow
    If Not mclsList Is Nothing Then
        Set mclsList.Grid = Nothing
    End If
    msgGrid.FixedCols = 0
    msgGrid.Rows = msgGrid.FixedRows + 1
    msgGrid.RowData(1) = 0
    mclsList.ColOfs = 4
    Set mclsList.Grid = msgGrid
    mclsList.ListSet.ViewId = ViewID_Alter
    Set Data1.Resultset = GetFixedAlterList()
    msgGrid.ColWidth(1) = 0
    msgGrid.ColWidth(2) = 0
    msgGrid.ColWidth(3) = 0
    mclsList.SetupStyle
    mclsList.ListSetToGrid
    RefreshCbo
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'        查找过程
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub msgGrid_RowColChange()
    On Error Resume Next
    
    mblnFind = False
    If msgGrid.Row > 0 And mclsList.RowSelected Then
        txtFind.Text = msgGrid.TextMatrix(msgGrid.Row, mclsList.SortedCol)
    Else
        txtFind.Text = ""
    End If
    mblnFind = True
End Sub

Private Sub mclsList_AfterSort(lngCol As Long)
    mblnSort = False
    ChangeSortCol
    mblnSort = True
End Sub

Private Sub ChangeSortCol()
    Dim lngCnt As Long
    Dim strTitle As String
    
    strTitle = msgGrid.TextMatrix(msgGrid.FixedRows - 1, mclsList.SortedCol)
    If Right(strTitle, 1) = "↑" Or Right(strTitle, 1) = "↓" Then
        strTitle = Left(strTitle, Len(strTitle) - 1)
    End If
    
    For lngCnt = 0 To cboFind.ListCount - 1
        If cboFind.list(lngCnt) = strTitle Then
            cboFind.ListIndex = lngCnt
        End If
    Next lngCnt
End Sub

'根据列表标题刷新查找框
Private Sub RefreshCbo()
    Dim lngCnt As Long
    
    With cboFind
        .Clear
        For lngCnt = 1 To msgGrid.Cols - 1
            If mclsList.ColSort(lngCnt) And msgGrid.ColWidth(lngCnt) > 100 Then
                If Right(msgGrid.TextMatrix(0, lngCnt), 1) = "↑" Or Right(msgGrid.TextMatrix(0, lngCnt), 1) = "↓" Then
                    .AddItem Left(msgGrid.TextMatrix(0, lngCnt), Len(msgGrid.TextMatrix(0, lngCnt)) - 1)
                Else
                    .AddItem msgGrid.TextMatrix(0, lngCnt)
                End If
            End If
        Next lngCnt
        If .ListCount > 0 Then
            .ListIndex = 0
        End If
    End With
End Sub

Private Sub txtFind_Change()
    If mblnFind Then
        mclsList.FindKey txtFind.Text
    End If
End Sub

'设置排序列
Private Sub cboFind_Click()
    mclsList.Sort GetGridCol(cboFind.Text, msgGrid), 1
End Sub

'再找
Private Sub cmdSeekAgain_Click()
    Dim lngRow As Long
    Dim intResult As Integer
    
    On Error Resume Next
    
    With msgGrid
        If .Row >= .FixedRows Then
            If .Row < .Rows - 1 Then
                lngRow = .Row + 1
            Else
                lngRow = 1
            End If
            intResult = StrComp(Left$(.TextMatrix(lngRow, mclsList.SortedCol), Len(txtFind.Text)), txtFind.Text, vbTextCompare)
            If mclsList.SortedType = 1 Then
                '升序
                Select Case intResult
                Case -1  '小于
                    Do While lngRow < .Rows - 1 And intResult = -1
                        lngRow = lngRow + 1
                        intResult = StrComp(Left$(.TextMatrix(lngRow, mclsList.SortedCol), Len(txtFind.Text)), txtFind.Text, vbTextCompare)
                    Loop
                Case 0   '等于
                Case 1   '大于
                    Do While lngRow > .FixedRows And intResult = 1
                        lngRow = lngRow - 1
                        intResult = StrComp(Left$(.TextMatrix(lngRow, mclsList.SortedCol), Len(txtFind.Text)), txtFind.Text, vbTextCompare)
                    Loop
                End Select
            Else
                '降序
                Select Case intResult
                Case -1  '小于
                    Do While lngRow > .FixedRows And intResult = 1
                        lngRow = lngRow - 1
                        intResult = StrComp(Left$(.TextMatrix(lngRow, mclsList.SortedCol), Len(txtFind.Text)), txtFind.Text, vbTextCompare)
                    Loop
                Case 0   '等于
                Case 1   '大于
                    Do While lngRow < .Rows - 1 And intResult = -1
                        lngRow = lngRow + 1
                        intResult = StrComp(Left$(.TextMatrix(lngRow, mclsList.SortedCol), Len(txtFind.Text)), txtFind.Text, vbTextCompare)
                    Loop
                End Select
            End If
            If intResult = 0 Then
                '找到
                .Row = lngRow
                .col = 0
                .ColSel = .Cols - 1
                If Not .RowIsVisible(.Row) Then
                    .TopRow = .Row
                End If
            End If
        End If
        .SetFocus
    End With
End Sub
'显示
Public Sub ShowMe()
    If Not Me.Visible Then
        Me.Hide
        RefreshAlterGrid
        chkShowAll_Click
        Me.Show
    End If
    Me.ZOrder 0
End Sub