newgrid.cls

金算盘软件代码

'返回至制定列宽度之和
Private Function GetColsWidth(ByVal intCol As Integer) As Long
    Dim intCnt As Integer
    Dim lngSum As Long
    Dim intFixedCol As Integer
        
    With mFlex
        intFixedCol = .FixedCols - 1
        If intCol > intFixedCol Then
            For intCnt = 1 To intFixedCol
                lngSum = lngSum + .ColWidth(intCnt)
            Next intCnt
            For intCnt = .LeftCol To intCol
                lngSum = lngSum + .ColWidth(intCnt)
            Next intCnt
        Else
            For intCnt = 1 To intCol
                lngSum = lngSum + .ColWidth(intCnt)
            Next
        End If
    End With
    GetColsWidth = lngSum
End Function

'判定是否出现水平和垂直滚动条
Private Sub ISScroll(ByRef blnHscroll As Boolean, ByRef blnVscroll As Boolean)
    If mFlex.Cols = mFlex.FixedCols + 1 Then
        blnHscroll = False
        blnVscroll = IsVScroll(0)
    Else
        blnHscroll = IsHScroll(gclsEniv.VScrollWidth)
        blnVscroll = IsVScroll(gclsEniv.HScrollHeight)
        If blnVscroll Then
            If blnHscroll Then
                If Not IsVScroll(0) Then
                    If Not IsHScroll(0) Then
                        blnHscroll = False
                        blnVscroll = False
                    End If
                End If
            Else
                blnVscroll = IsVScroll(0)
            End If
        Else
            If blnHscroll Then blnHscroll = IsHScroll(0)
        End If
    End If
    
    With mFlex
        If .ScrollBars = flexScrollBarNone Then
            blnHscroll = False
            blnVscroll = False
        ElseIf .ScrollBars = flexScrollBarVertical Then
            blnHscroll = False
        ElseIf .ScrollBars = flexScrollBarHorizontal Then
            blnVscroll = False
        End If
    End With
End Sub


'判定水平滚动条是否出现
Private Function IsHScroll(ByVal intVScrollWidth As Integer) As Boolean
    Dim intCnt As Integer
    Dim lngSum As Long
    
    With mFlex
        For intCnt = 1 To .Cols - 1
            lngSum = lngSum + .ColWidth(intCnt)
        Next
        If .width - 80 - intVScrollWidth >= lngSum Then
            IsHScroll = False
        Else
            IsHScroll = True
        End If
    End With
End Function

'判定垂直滚动条是否出现
Private Function IsVScroll(ByVal intHScrollHeight As Integer) As Boolean
    Dim lngSum As Long
    
    With mFlex
        lngSum = .Rows * .RowHeight(0)
        If .Height - intHScrollHeight >= lngSum + 42.5 Then
            IsVScroll = False
        Else
            IsVScroll = True
        End If
    End With
End Function

'画线
Private Sub GridDrawLine(ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal Color As Long)
    Dim hPen As Long, hSavePen As Long
    Dim Point As POINTAPI
    Dim blnIsVisible As Boolean
    
    x1 = x1 / Screen.TwipsPerPixelX
    x2 = x2 / Screen.TwipsPerPixelX
    y1 = y1 / Screen.TwipsPerPixelY
    y2 = y2 / Screen.TwipsPerPixelY
    
    '裁减作图区域
    blnIsVisible = True
    With mClipRect
        If x1 = x2 Then
            If (x1 < .Left Or x1 > .Right) Then
                blnIsVisible = False
            ElseIf y1 < .top And y2 < .top Then
                blnIsVisible = False
            ElseIf y1 > .Bottom And y2 > .Bottom Then
                blnIsVisible = False
            Else
                If y1 < .top Then y1 = .top
                If y2 > .Bottom Then y2 = .Bottom
            End If
        ElseIf y1 = y2 Then
            If (y1 < .top Or y1 > .Bottom) Then
                blnIsVisible = False
            ElseIf x1 < .Left And x2 < .Left Then
                blnIsVisible = False
            ElseIf x1 > .Right And x2 > .Right Then
                blnIsVisible = False
            Else
                If x1 < .Left Then x1 = .Left
                If x2 > .Right Then x2 = .Right
            End If
        End If
    End With
    
    If blnIsVisible Then
        hPen = CreatePen(PS_SOLID, 1, Color)
        hSavePen = SelectObject(hdc, hPen)
        MoveToEx hdc, x1, y1, Point
        LineTo hdc, x2, y2
        SelectObject hdc, hSavePen
        DeleteObject hPen
    End If
End Sub


'画实心区域
Private Sub GridDrawSolidBox(ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal Color As Long)
    Dim hPen As Long, hSavePen As Long
    Dim hBrush As Long, hSaveBrush As Long
    Dim blnIsVisible As Long
    
    x1 = x1 / Screen.TwipsPerPixelX
    x2 = x2 / Screen.TwipsPerPixelX
    y1 = y1 / Screen.TwipsPerPixelY
    y2 = y2 / Screen.TwipsPerPixelY
    
    '裁减作图区域
    blnIsVisible = True
    With mClipRect
        If x1 < .Left And x2 < .Left Then
            blnIsVisible = False
        ElseIf x1 > .Right And x2 > .Right Then
            blnIsVisible = False
        ElseIf y1 < .top And y2 < .top Then
            blnIsVisible = False
        ElseIf y1 > .Bottom And y2 > .Bottom Then
                blnIsVisible = False
        Else
            If x1 < .Left Then x1 = .Left
            If x2 > .Right Then x2 = .Right
            If y1 < .top Then y1 = .top
            If y2 > .Bottom Then y2 = .Bottom
        End If
    End With
    
    
    If blnIsVisible Then
        hPen = CreatePen(PS_SOLID, 1, Color)
        hSavePen = SelectObject(hdc, hPen)
        hBrush = CreateSolidBrush(Color)
        hSaveBrush = SelectObject(hdc, hBrush)
        Rectangle hdc, x1, y1, x2, y2
        SelectObject hdc, hSavePen
        SelectObject hdc, hSaveBrush
        DeleteObject hPen
        DeleteObject hBrush
    End If
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  Hook程序
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub mclsHook_OnMessage(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, bCancel As Long)
    Dim strText As String
    
    If Msg = WM_KILLFOCUS Then
        If Not Valid Then
            bCancel = True
        End If
    End If
End Sub



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  SubClass程序
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub mclsSubClassFlex_WndProc(Msg As Long, wParam As Long, lParam As Long, Result As Long)
    Dim lngX As Long, lngY As Long
    Dim blnCancel As Boolean
    Dim lngCnt As Long, lngCols As Long
    Dim intDX, intDY
    Dim blnIsOnCol As Boolean
    Static blnColResize As Boolean
    Select Case Msg
    Case WM_PAINT
        '取Paint事件矩形区域
        GetUpdateRect mFlex.hwnd, mClipRect, False
        
        Result = mclsSubClassFlex.CallWndProc(Msg, wParam, lParam)
        
        DrawGridLine
    Case WM_LBUTTONDOWN
        intDX = Screen.TwipsPerPixelX
        intDY = Screen.TwipsPerPixelY
        lngX = LoWord(lParam) * intDX
        lngY = HiWord(lParam) * intDY
        blnCancel = False
        If Not (EditObject Is Nothing) Then
            If EditObject.Visible Then
                blnCancel = Not Valid
            End If
        End If
        If Not blnCancel Then
            With mFlex
                If lngX < .ColPos(0) Or lngX > (.ColPos(.Cols - 1) + .ColWidth(.Cols - 1)) Or _
                   lngY < .RowPos(0) Or lngY > (.RowPos(.Rows - 1) + .RowHeight(.Rows - 1)) Then
                    '选中无效区域，光标消失
                    If Not ((wParam And MK_CONTROL) = MK_CONTROL Or (wParam And MK_SHIFT) = MK_SHIFT) Then
                        .col = 0
                        .ColSel = 0
                    End If
                    
                    blnCancel = True
                ElseIf .MouseRow = 0 Then
                    '选中标题区域：如果光标位于列分割线上，不处理；如果光标没有位于列分割线上并且当前列是可排序列，按列排序；
                    '如果光标没有位于列分割线上并且当前列是不可排序列，取消该消息。
                    mblnMouseDownOnFixedRow = True
                    blnIsOnCol = False
                    
                    lngCols = .FixedCols
                    For lngCnt = 1 To lngCols
                        If lngX > .ColPos(lngCnt) + intDX And lngX < .ColPos(lngCnt) + .ColWidth(lngCnt) - intDX Then
                            blnIsOnCol = True
                            Exit For
                        End If
                    Next lngCnt
                    
                    If Not blnIsOnCol Then
                        lngCols = .Cols - 1
                        For lngCnt = .LeftCol To lngCols
                            If lngX > .ColPos(lngCnt) + intDX And lngX < .ColPos(lngCnt) + .ColWidth(lngCnt) - intDX Then
                                blnIsOnCol = True
                                Exit For
                            End If
                        Next lngCnt
                    End If
                    
                    If blnIsOnCol Then
                        mlngMouseDownCol = lngCnt
                        
                        '光标没有位于列分割线上，取消该消息
                        blnCancel = True
                    Else
                        mlngMouseDownCol = 0
                        mblnColResize = True
                        blnColResize = True
                    End If
                Else
                    If .SelectionMode = flexSelectionByRow Then
                        If .Row <> .MouseRow Then
                            .Row = .MouseRow
                            blnCancel = True
                        End If
                        If .col <> 0 Then .col = 0
                        If .ColSel = 0 Then .ColSel = .Cols - 1
                    End If
                End If
            End With
            If Not blnCancel Then Result = mclsSubClassFlex.CallWndProc(Msg, wParam, lParam)
        End If
    Case WM_MOUSEMOVE
        ' 确保隐藏的第0列不被拖除
        If mFlex.MouseRow <> 0 Or mFlex.MouseCol <> 0 Then
            blnCancel = False
            If wParam = MK_LBUTTON Then
                If mFlex.MouseRow = 0 And mblnMouseDownOnFixedRow And mlngMouseDownCol > 0 Then
                    mblnMouseDownOnFixedRow = False
                    
                    '如果ListSet对象存在，不可拖动非ListSet列
                    If ListSet Is Nothing Or mlngMouseDownCol >= mlngColOfs Then
                        '启动拖动
                        mlngDragOverCol = -1
                        mFlex.Drag vbBeginDrag
                    End If
                End If
            End If
            
            If Not blnCancel Then Result = mclsSubClassFlex.CallWndProc(Msg, wParam, lParam)
        End If
    Case WM_LBUTTONUP
        If mblnMouseDownOnFixedRow And ColSort(mlngMouseDownCol) Then
            mblnMouseDownOnFixedRow = False
    
            With mFlex
                '排序
                If mlngMouseDownCol = mlngSortedCol And mlngSortedType = GridAscOrder Then
                    Sort mlngMouseDownCol, GridDescOrder
                Else
                    Sort mlngMouseDownCol, GridAscOrder
                End If
            End With
        End If

        Result = mclsSubClassFlex.CallWndProc(Msg, wParam, lParam)
        If blnColResize Then
            blnColResize = False
            TotalRowAdjust
            DrawTotalBox
        End If
    Case WM_KEYDOWN
        Result = mclsSubClassFlex.CallWndProc(Msg, wParam, lParam)
    Case Else
        Result = mclsSubClassFlex.CallWndProc(Msg, wParam, lParam)
    End Select
End Sub

Private Sub mclsSubClassText_WndProc(Msg As Long, wParam As Long, lParam As Long, Result As Long)
    If Not mblnNotKillText Then
        If Valid Then
            Result = mclsSubClassText.CallWndProc(Msg, wParam, lParam)
            EditObject.Visible = False
            SaveText
        Else
            On Error GoTo ErrHandle
            EditObject.SetFocus
        End If
    End If
ErrHandle:
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  mFlex的事件处理程序
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub mFlex_DragOver(Source As Control, x As Single, y As Single, State As Integer)
    Dim blnIsHScroll As Boolean, blnIsVScroll As Boolean
    Dim lngX As Long, lngY As Long
    Dim intDX As Integer, intDY As Integer
    Dim intOffset As Integer
    Dim hdc As Long
    Dim hPen As Long, hSavePen As Long
    Dim Point As POINTAPI
    Dim intMode As Integer
    Dim lngCol As Long, lngCnt As Long
    Dim lngStartCol As Long, lngEndCol As Long
    
    intDX = Screen.TwipsPerPixelX
    intDY = Screen.TwipsPerPixelY
    With mFlex
        If mlngMouseDownCol < .FixedCols Then
            lngStartCol = 1
            lngEndCol = .FixedCols - 1
        Else
            lngStartCol = .FixedCols
            If lngStartCol < 1 Then lngStartCol = 1
            lngEndCol = .Cols - 1
        End If
        
        If x <= .ColPos(lngStartCol) Then
            lngCol = lngStartCol
        ElseIf x >= .ColPos(lngEndCol) + .ColWidth(lngEndCol) Then
            lngCol = lngEndCol + 1
        Else
            For lngCnt = lngStartCol To lngEndCol
                If x >= .ColPos(lngCnt) And x < .ColPos(lngCnt) + .ColWidth(lngCnt) Then
                    lngCol = lngCnt
                    Exit For
                End If
            Next
        End If
        
        If mlngDragOverCol = lngCol Then
            Exit Sub
        End If
        
        '判断水平滚动条和垂直滚动条
        ISScroll blnIsHScroll, blnIsVScroll
        
        intOffset = IIf(.Appearance = flex3D, 4, 0)
        If blnIsHScroll Then
            lngY = (.Height - gclsEniv.HScrollHeight) / intDY - intOffset
        Else
            lngY = .Height / intDY - intOffset
        End If
        
        hdc = GetDC(.hwnd)
        hPen = CreatePen(PS_SOLID, 3, RGB(255, 255, 255))
        hSavePen = SelectObject(hdc, hPen)
        intMode = SetROP2(hdc, R2_XORPEN)
        
        If mlngDragOverCol >= 0 Then
            If mlngDragOverCol >= .Cols Then
                lngX = (.ColPos(mlngDragOverCol - 1) + .ColWidth(mlngDragOverCol - 1)) / intDX - 1
            Else
                lngX = .ColPos(mlngDragOverCol) / intDX - 1
            End If
            MoveToEx hdc, lngX, 0, Point