mutigrid.cls

金算盘软件代码

End Sub

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

'判定是否出现水平和垂直滚动条
Private Sub ISScroll(ByRef blnHscroll As Boolean, ByRef blnVscroll As Boolean)
    If mBodyFlex.Cols = mBodyFlex.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 mBodyFlex
        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 intSum As Integer
    
    With mBodyFlex
        For intCnt = 1 To .Cols - 1
            intSum = intSum + .ColWidth(intCnt)
        Next
        If .width - 80 - intVScrollWidth >= intSum 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 mBodyFlex
        If .Rows > 0 Then
            lngSum = .Rows * .RowHeight(0)
            If .Height - intHScrollHeight >= lngSum + 42.5 Then
                IsVScroll = False
            Else
                IsVScroll = True
            End If
        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


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  SubClass程序(Body)
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub mclsSubClassBody_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
    
    Select Case Msg
    Case WM_PAINT
        '取Paint事件矩形区域
        GetUpdateRect mBodyFlex.hwnd, mClipRect, False
        
        Result = mclsSubClassBody.CallWndProc(Msg, wParam, lParam)
        
        DrawGridLine
    Case WM_LBUTTONDOWN
        intDX = Screen.TwipsPerPixelX
        intDY = Screen.TwipsPerPixelY
'        lngX = CInt(lParam And &HFFFF&) * intDX
'        lngY = CInt((lParam And &HFFFF0000) \ &H10000) * intDY
        lngX = LoWord(lParam) * intDX
        lngY = HiWord(lParam) * intDY
        blnCancel = False
        With mBodyFlex
            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
                    mblnRowSel = False
                End If
                
                blnCancel = True
            ElseIf .MouseRow = 0 And .FixedRows > 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
                End If
            Else
                If .SelectionMode = flexSelectionByRow Then
                    If .Row <> .MouseRow And .Rows > .FixedRows Then
                        .Row = .MouseRow
                        blnCancel = True
                    End If
                    If .col <> 0 Then .col = 0
                    If .ColSel = 0 Then .ColSel = .Cols - 1
                    mblnRowSel = True
                End If
            End If
        End With
        If Not blnCancel Then Result = mclsSubClassBody.CallWndProc(Msg, wParam, lParam)
    Case WM_MOUSEMOVE
        ' 确保隐藏的第0列不被拖除
        If mBodyFlex.MouseRow <> 0 Or mBodyFlex.MouseCol <> 0 Then
            blnCancel = False
            If wParam = MK_LBUTTON Then
                If mBodyFlex.MouseRow = 0 And mblnMouseDownOnFixedRow And mlngMouseDownCol > 0 Then
                    mblnMouseDownOnFixedRow = False
                    
                    '隐藏编辑
                    If Not (mEditObject Is Nothing) Then
                        If mEditObject.Visible Then
                            mEditObject.Visible = False
                        End If
                    End If
                    
                    '如果ListSet对象存在，不可拖动非ListSet列
                    If ListSet.ViewId <> 0 And mlngMouseDownCol >= mlngColOfs Then
                        '启动拖动
                        mBodyFlex.Drag vbBeginDrag
                    End If
                End If
            End If
            
            If Not blnCancel Then Result = mclsSubClassBody.CallWndProc(Msg, wParam, lParam)
        End If
    Case WM_LBUTTONUP
        If mblnMouseDownOnFixedRow And ColSort(mlngMouseDownCol) Then
            mblnMouseDownOnFixedRow = False
    
            With mBodyFlex
                '排序
                If mlngMouseDownCol = mlngSortedCol And mlngSortedType = GridAscOrder Then
                    Sort mlngMouseDownCol, GridDescOrder
                Else
                    Sort mlngMouseDownCol, GridAscOrder
                End If
            End With
        End If

        Result = mclsSubClassBody.CallWndProc(Msg, wParam, lParam)
        If mblnColResize Then
           mblnColResize = False
           mblnSaveList = True
        End If
    Case Else
        Result = mclsSubClassBody.CallWndProc(Msg, wParam, lParam)
    End Select
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  SubClass程序(Head)
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub mclsSubClassHead_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
    
    Select Case Msg
    Case WM_PAINT
        '取Paint事件矩形区域
        GetUpdateRect mBodyFlex.hwnd, mClipRect, False
        
        Result = mclsSubClassHead.CallWndProc(Msg, wParam, lParam)
        
        DrawGridLine
    Case WM_LBUTTONDOWN
        intDX = Screen.TwipsPerPixelX
        intDY = Screen.TwipsPerPixelY
'        lngX = CInt(lParam And &HFFFF&) * intDX
'        lngY = CInt((lParam And &HFFFF0000) \ &H10000) * intDY
        lngX = LoWord(lParam) * intDX
        lngY = HiWord(lParam) * intDY
        blnCancel = False
        With mHeadFlex
            If .MouseRow >= 0 And .MouseRow <= .FixedRows - 1 Then
                '选中标题区域：如果光标位于列分割线上，不处理；如果光标没有位于列分割线上并且当前列是可排序列，按列排序；
                '如果光标没有位于列分割线上并且当前列是不可排序列，取消该消息。
                mblnMouseDownOnFixedRow = True
                blnIsOnCol = False
                
                lngCols = .FixedCols
                For lngCnt = 1 To lngCols
                    If lngX > GetRealColPos(lngCnt) + intDX And lngX < GetRealColPos(lngCnt) + .ColWidth(lngCnt) - 2 * intDX Then
                        blnIsOnCol = True
                        Exit For
                    End If