MouseWheel Scroll in FlexGrid 1

[tudogs]

After three evenings of head bashing I finally made this work in Win98, 2k, XP.
This will work with multiple FlexGrids on a form.
I hope some of you may be able to use this code.

'PLACE FOLLOWING CODE IN A MODULE

Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, _
ByVal msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long

Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long

Public Const MK_CONTROL = &H8
Public Const MK_LBUTTON = &H1
Public Const MK_RBUTTON = &H2
Public Const MK_MBUTTON = &H10
Public Const MK_SHIFT = &H4
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A

Dim LocalHwnd As Long
Dim LocalPrevWndProc As Long
Dim MyForm As Form
Public PageScroll As Boolean


Public Sub WheelHook(PassedForm As Form)

    On Error Resume Next

    Set MyForm = PassedForm
    LocalHwnd = PassedForm.hWnd
    LocalPrevWndProc = SetWindowLong(LocalHwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub


Public Sub WheelUnHook()
    Dim WorkFlag As Long

    On Error Resume Next
    WorkFlag = SetWindowLong(LocalHwnd, GWL_WNDPROC, LocalPrevWndProc)
    Set MyForm = Nothing
End Sub


Private Function WindowProc(ByVal Lwnd As Long, ByVal Lmsg As Long,_
 ByVal wParam As Long, ByVal lParam As Long) As Long

    Dim MouseKeys As Long
    Dim Rotation As Long
    Dim Xpos As Long
    Dim Ypos As Long

    If Lmsg = WM_MOUSEWHEEL Then
        MouseKeys = wParam And 65535
        Rotation = wParam / 65536
        Xpos = lParam And 65535
        Ypos = lParam / 65536
        MyForm.MouseWheel MouseKeys, Rotation, Xpos, Ypos
    End If
    WindowProc = CallWindowProc(LocalPrevWndProc, Lwnd, Lmsg, wParam, lParam)
End Function


'NOW PLACE THE FOLLOWING CODE INTO EACH FORM

'This code is for scrolling the MSFlexGrid
'  I'll Leave it up to you to scroll anything else.
'  This code will scroll multiple flexgrids on each form.


Public Sub MouseWheel(ByVal MouseKeys As Long, ByVal Rotation As Long,_
 ByVal Xpos As Long, ByVal Ypos As Long)
    Dim NewValue As Long
    Dim Lstep As Single
    On Error Resume Next
    With Screen.ActiveControl
        If TypeOf Screen.ActiveControl Is MSFlexGrid Then

            If PageScroll = True Then ' determine page length if scrolling by page
                Lstep = .Height / .RowHeight(0)
                Lstep = Int(Lstep - 3) ' the -3 allows for row 0 and for any '                                        horizontalscrollbar
                Text9.Text = Lstep

            Else
                Lstep = 1 ' scroll by line
            End If
            If Rotation > 0 Then 
                NewValue = .TopRow - Lstep ' scrolling up
                If NewValue < 1 Then
                    NewValue = 1
                End If
            Else
                NewValue = .TopRow + Lstep ' scrolling down
                If NewValue > .Rows - 1 Then
                    NewValue = .Rows - 1
                End If
            End If
            .TopRow = NewValue ' perform scroll
        End If
    End With
End Sub

'**************************

'Now in each flexgrid do this:

Private Sub msfFlexGrid_GotFocus()

Call WheelHook(Me) ' hookup to Windows message stream

End Sub


Private Sub msfFlexGrid_LostFocus()

Call WheelUnHook ' Unhook from Windows message stream.  This is necessary 
                 ' so you can just move over the next grid and start scrolling.  

End Sub


Private Sub msfFlexGrid_MouseMove(Button As Integer, Shift As Integer,_
 x As Single, y As Single)

    msfFlexGrid.SetFocus ' this will cause gotfocus as mouse moves over the Grid.  
'                          Can't hookup here as mousemove fires repeatedly and 
'                          therefor sends the App into Never-Never Land.

End Sub


' And in each form:


Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

    If KeyCode = vbKeyControl Then
        PageScroll = True ' allow page scrolling
        
    End If
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)

        PageScroll = False ' Scroll Line by Line

End Sub

Set each form's Keypreview property to True

This will allow you to scroll a page at a time by holding down the Control Key while scrolling.
Otherwise you will scroll line by line.

Good Luck
Bob


Daughters are Gods Vengeance on Fathers for being Men.

 

[RubenV]

This is a great tip and something very useful.
I tested it very quickly and it's indeed very neat.

Good job

 

[strongm]

I think it would have been nice if you had actually credited

http://www.adit.co.uk/html/mousewheelsupport.html

 

[RubenV]

Hmm, but there's some added code.

Anyway, it might have been nice indeed but it's nice to say the least. Well, if you can use it.

 

[strongm]

>there's some added code

There's a minor modification. I just get irritated when someone else's hard work is ignored.

That aside, it is a useful tip.