frmaccountfixedasset.frm

金算盘软件代码

                    & ",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
                strSql = "DELETE FROM FixedAux 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 = "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 " _
                    & "WHERE lngFixedCardID=" & lngCardID & " AND intYear=" & intYear _
                    & " AND bytPeriod=" & bytPeriod
                If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
                strSql = "DELETE FROM FixedBalance WHERE lngFixedCardID=" & lngCardID _
                    & " AND dblDeprection=0 AND dblWork=0 AND intPeriod=0 AND intYear=" & intYear _
                    & " AND bytPeriod=" & bytPeriod
                If Not gclsBase.ExecSQL(strSql) Then GoTo HandleErr
                UpdateFixedBalanceAfterDelete lngCardID, intYear, bytPeriod, lngLastFixedAlterID
            End If
        End If
    End If
    recAlter.Close
    gclsBase.BaseWorkSpace.CommitTrans
    DeleteFix = True
    Exit Function
    
HandleErr:
    gclsBase.BaseWorkSpace.RollbackTrans
    errNo = Errors.ErrorsDeal()
    Select Case errNo
    Case edtResume: Resume
    Case edtResumeNext: Resume Next
    Case edtCanNotKnown
        ShowMsg hwnd, "程序出错：" & Err.Description, vbOKOnly + vbCritical, Caption
    End Select
End Function

'筛选
Private Sub SelWithFilter()
    Dim blnOK As Boolean
    
    If mclsList.ListSet.ListID = 0 Then
        mclsList.ListSet.SaveList
        DefaultCurrentDate mclsList.ListSet.ListID, 1873
    End If
    Filter.ShowFilter mclsList.ListSet.ListID, 1, , , , , blnOK
    If blnOK Then
        tabList_Click 1
    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()
    mlngLastSortedCol = mclsList.SortedCol
    mlngLastSortedType = mclsList.SortedType
    
    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 RefreshWorkGrid()
    Dim lngCol As Long
    mlngLastSortedCol = mclsList.SortedCol
    mlngLastSortedType = mclsList.SortedType
    mclsList.FormatData = True
    msgGrid.SelectionMode = flexSelectionFree
    msgGrid.FixedCols = 0
    msgGrid.Rows = msgGrid.FixedRows + 1
    msgGrid.RowData(1) = 0
    If Not mclsList.Grid Is Nothing Then
        Set mclsList.Grid = Nothing
    End If
    mclsList.ColOfs = 1
    Set mclsList.Grid = msgGrid
    mclsList.ListSet.ViewId = ViewID_Work
    Set Data1.Resultset = GetWorkAmountList()
    mclsList.SetupStyle
    mclsList.ListSetToGrid
    If Not PeriodDepection(gclsBase.AccountYear, gclsBase.Period) Then
        Set mclsList.EditText = txtEdit
        mclsList.SetEditText "本期工作量", ""
    Else
        For lngCol = 0 To msgGrid.Cols - 1
            mclsList.ReadOnlyCol(lngCol) = True
        Next lngCol
        txtEdit.Visible = False
    End If
    RefreshCbo
    RefreshWork
End Sub

Private Sub RefreshCardGrid()
    mlngLastSortedCol = mclsList.SortedCol
    mlngLastSortedType = mclsList.SortedType
    msgGrid.SelectionMode = flexSelectionByRow
    msgGrid.FixedCols = 0
    msgGrid.Rows = msgGrid.FixedRows + 1
    msgGrid.RowData(1) = 0
    If Not mclsList.Grid Is Nothing Then
        Set mclsList.Grid = Nothing
    End If
    mclsList.ColOfs = 1
    Set mclsList.Grid = msgGrid
    mclsList.ListSet.ViewId = ViewID_Card
    Set Data1.Resultset = GetFixedCardList()
    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
            If mlngLastSortedCol >= mclsList.ColOfs And mlngLastSortedCol - mclsList.ColOfs < cboFind.ListCount Then
                .ListIndex = mlngLastSortedCol - mclsList.ColOfs
            Else
                .ListIndex = 0
            End If
        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), mlngLastSortedType
    msgGrid_RowColChange
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


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 录入工作量
'
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub mclsList_DataValid(blnCancel As Boolean)
    Dim dblTotal As Double
    Dim dblAccWork As Double
    Dim intCol1 As Integer
    Dim intCol2 As Integer
    
    intCol1 = GetGridCol("预计总工作量", msgGrid)
    intCol2 = GetGridCol("月初累计工作量", msgGrid)
    
    txtEdit.Text = txtEdit.Value
    If intCol1 > 0 And intCol2 > 0 Then
        dblTotal = GetValue(msgGrid.Row, intCol1)
        dblAccWork = GetValue(msgGrid.Row, intCol2)
        If txtEdit.Value < 0 Then
            ShowMsg hwnd, "本月工作量不能小于0！", vbExclamation, Me.Caption
            blnCancel = True
        ElseIf txtEdit.Value - (dblTotal - dblAccWork) > 0.0000001 Then
            ShowMsg hwnd, "本月工作量不能超过剩余工作量！", vbExclamation, Me.Caption
            blnCancel = True
        End If
    End If
End Sub

Private Sub mclsList_AfterSave()
    Dim lngCardID As Long
    Dim dblWork As Double
    Dim strSql As String
    Dim recBalance As rdoResultset
    Dim blnNotExist As Boolean
    Dim dblWorkDiff As Double
    
    blnNotExist = False
    lngCardID = GetValue(msgGrid.Row, 0)
    dblWork = GetValue(msgGrid.Row, msgGrid.col)
    msgGrid.TextMatrix(msgGrid.Row, msgGrid.col) = IIf(dblWork = 0, "", dblWork)
    strSql = "SELECT * FROM FixedBalance WHERE intYear * 100 + bytPeriod = " & CLng(gclsBase.Acco