tablegrid.cls

金算盘软件代码

    '用二分法进行查找匹配
    With mDBTableCtrl
        If blnIsText Then
            strKey = UCase(strKey)
        Else
            If Not IsNumeric(strKey) Then
                Exit Function
            Else
                dblKey = CDbl(strKey)
            End If
        End If
        
        lngStart = .FixedRows
        lngEnd = .Rows - 1
        Do While (lngEnd - lngStart) > 1
            lngMiddle = lngStart + (lngEnd - lngStart) \ 2
            strText = UCase(.CellValue(lngMiddle, mintSortCol))
            If blnIsText Then
                intResult = StrComp(Left(strText, Len(strKey)), strKey, vbTextCompare)
            Else
                If Not IsNumeric(strText) Then
                    intResult = 1
                Else
                    dblNumeric = CDbl(strText)
                    If dblNumeric < dblKey Then
                        intResult = -1
                    ElseIf dblNumeric = dblKey Then
                        intResult = 0
                    Else
                        intResult = 1
                    End If
                End If
            End If
            
            Select Case intResult
            Case -1
                If mintSortType = 1 Then          '升序排列
                    lngStart = lngMiddle
                Else                        '降序排列
                    lngEnd = lngMiddle
                End If
            Case 0
                lngEnd = lngMiddle
            Case 1
                If mintSortType = 1 Then            '升序排列
                    lngEnd = lngMiddle
                Else                        '降序排列
                    lngStart = lngMiddle
                End If
            End Select
        Loop
        
        strText = UCase(.CellValue(lngStart, mintSortCol))
        If blnIsText Then
            intResult = StrComp(Left(strText, Len(strKey)), strKey, vbTextCompare)
        Else
            If Not IsNumeric(strText) Then
                intResult = 1
            Else
                dblNumeric = CDbl(strText)
                If dblNumeric < dblKey Then
                    intResult = -1
                ElseIf dblNumeric = dblKey Then
                    intResult = 0
                Else
                    intResult = 1
                End If
            End If
        End If
        
        If intResult = 0 Then
            .Row = lngStart
            blnFind = True
        Else
            strText = UCase(.CellValue(lngEnd, mintSortCol))
            If blnIsText Then
                intResult = StrComp(Left(strText, Len(strKey)), strKey, vbTextCompare)
            Else
                If Not IsNumeric(strText) Then
                    intResult = 1
                Else
                    dblNumeric = CDbl(strText)
                    If dblNumeric < dblKey Then
                        intResult = -1
                    ElseIf dblNumeric = dblKey Then
                        intResult = 0
                    Else
                        intResult = 1
                    End If
                End If
            End If
            If intResult = 0 Then
                .Row = lngEnd
                blnFind = True
            End If
        End If
    End With
    
    If blnFind Then
        FindKey = strText
    End If
End Function

'指定排序列
Public Sub Sort(ByVal lngCol As Long)
    Dim blnRefresh As Boolean
    If lngCol - mlngColOfs + 1 > 0 Then
        If mclsListSet.ColumnOrderType(lngCol - mlngColOfs + 1) > 0 Then
            mintSortCol = lngCol
            RaiseEvent RefreshRecord(blnRefresh)
            If blnRefresh Then RefreshGrid
        End If
    End If
End Sub

'设置开始排序列
Public Sub SetSortCol(ByVal vNewValue As String)
    Dim lngCol As Long
    
    With mDBTableCtrl
        For lngCol = 1 To .Cols - 1
            If .CellFormula(0, lngCol) = vNewValue Then
                mintSortCol = lngCol
                Exit For
            End If
        Next lngCol
    End With
End Sub

'添加、删除排序标志
Public Sub ClearSortColArrow()
    Dim strTitle As String
    
    With mDBTableCtrl
        If mintSortCol <= 0 Or mintSortCol > .Cols - 1 Then Exit Sub
        strTitle = .CellFormula(0, mintSortCol)
        If Right(strTitle, 1) = "↑" Or Right(strTitle, 1) = "↓" Then
            .CellFormula(0, mintSortCol) = Left(strTitle, Len(strTitle) - 1)
        End If
    End With
    '格式所有行
    FormatColData True
End Sub

Public Sub AddSortColArrow()
    Dim strTitle As String
    With mDBTableCtrl
        If mintSortCol <= 0 Or mintSortCol > .Cols - 1 Then Exit Sub
        strTitle = .CellFormula(0, mintSortCol)
        If Right(strTitle, 1) <> "↑" And Right(strTitle, 1) <> "↓" Then
            If mintSortType = 1 Then
                .CellFormula(0, mintSortCol) = strTitle & "↑"
            Else
                .CellFormula(0, mintSortCol) = strTitle & "↓"
            End If
        End If
    End With
End Sub

Public Sub SetFormatPara(ByVal intTargetCol As Integer, ByVal intSourceCol1 As Integer, _
    ByVal strOperand As String, ByVal intSourceCol2 As Integer, _
    Optional ByVal intTargetColType As Integer = 0, _
    Optional ByVal intTargetColDec As Integer = 2)
    If intTargetCol > 0 Then
        mintTargetCnt = mintTargetCnt + 1
        If mintTargetCnt > 0 Then
            ReDim Preserve mintTargetCol(mintTargetCnt - 1)
            ReDim Preserve mintSourceCol1(mintTargetCnt - 1)
            ReDim Preserve mintSourceCol2(mintTargetCnt - 1)
            ReDim Preserve mstrOperand(mintTargetCnt - 1)
            ReDim Preserve mintTargetColType(mintTargetCnt - 1)
            ReDim Preserve mintTargetColDec(mintTargetCnt - 1)
            mintTargetCol(mintTargetCnt - 1) = intTargetCol
            mintSourceCol1(mintTargetCnt - 1) = intSourceCol1
            mintSourceCol2(mintTargetCnt - 1) = intSourceCol2
            mstrOperand(mintTargetCnt - 1) = strOperand
            mintTargetColType(mintTargetCnt - 1) = intTargetColType
            mintTargetColDec(mintTargetCnt - 1) = intTargetColDec
        End If
    End If
End Sub










'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' 私有方法
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'处理鼠标单击Grid固定行
Private Sub mDBTableCtrl_AfterWindowProc(ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
    Select Case Message
    Case WM_LBUTTONUP
        Dim lngRow As Long, lngCol As Integer
        Dim blnRefresh As Boolean
        With mDBTableCtrl
            .MouseCell lngRow, lngCol
            If lngRow < .FixedRows And lngCol < .Cols Then
                If lngCol = mintSortCol Then
                    If mintSortType = 1 Then
                        mintSortType = 2
                    Else
                        mintSortType = 1
                    End If
                    RaiseEvent RefreshRecord(blnRefresh)
                    If blnRefresh Then RefreshGrid
                Else
                    If mclsListSet.ColumnOrderType(lngCol - mlngColOfs + 1) > 0 Then
                        mintSortCol = lngCol
                        RaiseEvent RefreshRecord(blnRefresh)
                        If blnRefresh Then RefreshGrid
                    End If
                End If
            Else
               RaiseEvent AfterRowColChange
            End If
        End With
    Case WM_KEYUP
        RaiseEvent AfterRowColChange
    Case WM_KEYDOWN
    Case WM_PAINT
        If mlngEndFormatRow < mDBTableCtrl.BottomRow And mlngEndFormatRow > 0 Then
            FormatColData
        End If
    End Select
End Sub

'根据Grid设置ListSet对象中列宽度、当前排序列及排序方式
Private Sub GridToListSet()
    Dim lngCnt As Long

    If mclsListSet.ViewId = 0 Then Exit Sub
    
    With mDBTableCtrl
        For lngCnt = mlngColOfs To .Cols - 1
            mclsListSet.ColumnWidth(lngCnt - mlngColOfs + 1) = .ColWidth(lngCnt) * Screen.TwipsPerPixelX
            mclsListSet.ColumnOrderType(lngCnt - mlngColOfs + 1) = GridNoOrder
        Next lngCnt
    End With
        
    If mintSortCol >= mlngColOfs And mintSortType <> GridNoOrder Then
        mclsListSet.ColumnOrderType(mintSortCol - mlngColOfs + 1) = mintSortType
    End If
End Sub

Private Sub ValidTargetCol()
    Dim lngCnt As Long
    
    For lngCnt = 0 To mintTargetCnt - 1
        If Abs(mintTargetCol(lngCnt)) > 0 And Abs(mintTargetCol(lngCnt)) < mlngMaxCols And _
            Abs(mintSourceCol1(lngCnt)) > 0 And Abs(mintSourceCol1(lngCnt)) < mlngMaxCols And _
            Abs(mintSourceCol2(lngCnt)) > 0 And Abs(mintSourceCol2(lngCnt)) < mlngMaxCols Then
            mintTargetCol(lngCnt) = Abs(mintTargetCol(lngCnt))
        Else
            mintTargetCol(lngCnt) = -Abs(mintTargetCol(lngCnt))
        End If
    Next lngCnt
End Sub

Private Sub FormatColData(Optional blnFormatAll As Boolean = False)
    Dim intCnt As Integer
    Dim dblBalance() As Double
    Dim dblTmp As Double
    Dim lngRows As Long
    
    On Error GoTo ErrHandle
    
    If mlngMaxRows < mDBTableCtrl.BottomRow Or blnFormatAll Then
        lngRows = mlngMaxRows + mDBTableCtrl.FixedRows - 1
    Else
        lngRows = mDBTableCtrl.BottomRow
    End If
    If mlngEndFormatRow < lngRows And mintTargetCnt > 0 Then
        If mintTargetCnt > 0 Then
            ReDim dblBalance(mintTargetCnt - 1)
        End If
        For intCnt = 0 To mintTargetCnt - 1
            If mintTargetColType(intCnt) = -1 Then
                If mlngEndFormatRow > mDBTableCtrl.FixedRows Then
                    If Not IsNull(mDBTableCtrl.CellValue(mlngEndFormatRow - 1, mintTargetCol(intCnt))) Then
                        dblBalance(intCnt) = mDBTableCtrl.CellValue(mlngEndFormatRow - 1, mintTargetCol(intCnt))
                    End If
                Else
                    If Not IsNull(mDBTableCtrl.CellValue(mlngEndFormatRow, mintTargetCol(intCnt))) Then
                        dblBalance(intCnt) = mDBTableCtrl.CellValue(mlngEndFormatRow, mintTargetCol(intCnt))
                    End If
                End If
            End If
        Next intCnt
            
        For mlngEndFormatRow = mlngEndFormatRow To lngRows
            For intCnt = 0 To mintTargetCnt - 1
                dblTmp = 0
                If Not IsNull(mDBTableCtrl.CellValue(mlngEndFormatRow, mintSourceCol1(intCnt))) Then
                    If IsNumeric(mDBTableCtrl.CellValue(mlngEndFormatRow, mintSourceCol1(intCnt))) Then
                        dblTmp = mDBTableCtrl.CellValue(mlngEndFormatRow, mintSourceCol1(intCnt))
                    End If
                End If
                If Not IsNull(mDBTableCtrl.CellValue(mlngEndFormatRow, mintSourceCol2(intCnt))) Then
                    If IsNumeric(mDBTableCtrl.CellValue(mlngEndFormatRow, mintSourceCol2(intCnt))) Then
                    Select Case mstrOperand(intCnt)
                    Case "+"
                        dblTmp = dblTmp + mDBTableCtrl.CellValue(mlngEndFormatRow, mintSourceCol2(intCnt))
                    Case "-"
                        dblTmp = dblTmp - mDBTableCtrl.CellValue(mlngEndFormatRow, mintSourceCol2(intCnt))
                    Case "*"
                        dblTmp = dblTmp * mDBTableCtrl.CellValue(mlngEndFormatRow, mintSourceCol2(intCnt))
                    Case "/"
                        If mDBTableCtrl.CellValue(mlngEndFormatRow, mintSourceCol2(intCnt)) <> 0 Then
                            dblTmp = dblTmp / mDBTableCtrl.CellValue(mlngEndFormatRow, mintSourceCol2(intCnt))
                        Else
                            dblTmp = 0
                        End If
                    End Select
                    End If
                End If
                If mintTargetColType(intCnt) = -1 Then
                    dblBalance(intCnt) = dblBalance(intCnt) + dblTmp
                Else
                    dblBalance(intCnt) = dblTmp
                End If
                mDBTableCtrl.CellFormula(mlngEndFormatRow, mintTargetCol(intCnt)) = AdjustDec(dblBalance(intCnt), mintTargetColDec(mintTargetCnt - 1))
            Next intCnt
        Next mlngEndFormatRow
    End If
    Exit Sub
    
ErrHandle:
    
End Sub