msflexgrid mouse wheel 1

[sal21]

msflexgrid mouse wheel, excample, please.
tks

 

[strongm]

So, here's the thing. The MS Flexgrid control does not support the mouse wheel. If you really, really need mouse wheel functionality you'll need to put in a hook procedure (this involves some low-level API work) to trap the mouse messages and respond to them.

 

[sal21]

tk strong.
have a code for tath?

 

[strongm]

Here's an illustration. Again, it is NOT a fully-worked solution.

The following goes in a module:

[COLOR=blue]Option Explicit

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" 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 Const GWL_WNDPROC = (-4)
Private Const WM_MOUSEWHEEL = &H20A

Private hOldWheelProc As Long

Private Type vbWParam
    Hiword As Long
    Loword As Long
End Type

Public Sub HookMWheel(ParentWnd As Long)
     If hOldWheelProc <> 0 Then Exit Sub
     hOldWheelProc = GetWindowLong(ParentWnd, GWL_WNDPROC)
     SetWindowLong ParentWnd, GWL_WNDPROC, AddressOf MWheelProc
End Sub

Public Sub UnHookMWheel(ParentWnd As Long)
     If hOldWheelProc = 0 Then Exit Sub
     SetWindowLong ParentWnd, GWL_WNDPROC, hOldWheelProc
End Sub

[COLOR=green]' Warning: any bugs in here, or attempts at debugging whilst in this function will at best casue
' unpredictable behaviour from Windows, and mostly hard crash VB.[/color]
Private Function MWheelProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim myWParam As vbWParam
    
    ' One of several methods to extract Hi- and lo-words from WParam
    myWParam.Hiword = wParam / &H10000
    myWParam.Loword = wParam And &HFFFF
    
    Select Case wMsg
    Case WM_MOUSEWHEEL [COLOR=green]' Ah, the mouswheel is in use[/color]
        [COLOR=green]' This is where you'd control the scroll of the flexgrid, assuming you are over the flexgrid when this event happens
        ' e.g. check coords held in lParam against flexgrid[/color]
        Select Case Sgn(myWParam.Hiword)
        Case 1:    Debug.Print "Scroll up":
        [COLOR=green]'If Form1.MSFlexGrid1.TopRow > 1 Then Form1.MSFlexGrid1.TopRow = Form1.MSFlexGrid1.TopRow - 1[/color]
        Case -1:   Debug.Print "Scroll down"
        [COLOR=green]'Form1.MSFlexGrid1.TopRow = Form1.MSFlexGrid1.TopRow + 1[/color]
        End Select
    Case Else
        MWheelProc = CallWindowProc(hOldWheelProc, hWnd, wMsg, wParam, lParam)
    End Select
End Function[/color]

And we engage the hook with code in the form:

[COLOR=blue]Option Explicit

Private Sub Form_Load()
     HookMWheel Me.hWnd '
End Sub

[COLOR=green]' Always exit via form's close button, else you will leave
' an unterminbated hook in place, which
' will generally crash VB to desktop[/color]
Private Sub Form_Unload(Cancel As Integer)
     UnHookMWheel Me.hWnd
End Sub[/color]

 

[sal21]

ok tks.
buty i dont see in any part of code the reference of msflexgrid, or not?

 

[strongm]

1) As I said, it is not a fully worked solution. I'm not going to write all your code for you.
2) You haven't read the code closely, including the comments, have you?

 

[sal21]

Sorry me, but i have read with attention your comment....
modified the code and work perfect!
Tks strongm.

only a curiosity ...

i have tree msflexgrid how to set for msflexgrid2 and msflexgrid3?

 

[strongm]

[tt]>'This is where you'd control the scroll of the flexgrid, assuming you are over the flexgrid when this event happens
>' e.g. check coords held in lParam against flexgrid[/tt]

So you need to check which flexgrid you are over when you use the wheel, and the use code to scroll that particular msflexgrid. The EXAMPLE here is hardcoded for MSFlexgrid1 (and doesn't bother with any checking)

 

[strongm]

Given it was only a minor modification, here's an expanded example (code for the Form remains unchanged). You can place multiple MSFlexGrids on the form, and only the one under the mpouse pointer should scroll when you use the mouse wheel:

[COLOR=blue]Option Explicit

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
[COLOR=red][b]Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long[/b][/color]

Private Const GWL_WNDPROC = (-4)
Private Const WM_MOUSEWHEEL = &H20A

Private hOldWheelProc As Long

Private Type vbWParam
    Hiword As Long
    Loword As Long
End Type

Public Sub HookMWheel(ParentWnd As Long)
     If hOldWheelProc <> 0 Then Exit Sub
     hOldWheelProc = GetWindowLong(ParentWnd, GWL_WNDPROC)
     SetWindowLong ParentWnd, GWL_WNDPROC, AddressOf MWheelProc
End Sub

Public Sub UnHookMWheel(ParentWnd As Long)
     If hOldWheelProc = 0 Then Exit Sub
     SetWindowLong ParentWnd, GWL_WNDPROC, hOldWheelProc
End Sub

[COLOR=green]' Warning: any bugs in here, or attempts at debugging whilst in this function will at best cause 
' unpredictable behaviour from Windows, and mostly hard crash VB.[/color]
Private Function MWheelProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim myWParam As vbWParam
    [COLOR=red][b]Dim mygrid As MSFlexGrid[/b][/color]
    
    [COLOR=green]' One of several methods to extract Hi- and lo-words from WParam[/color]
    myWParam.Hiword = wParam \ &H10000
    myWParam.Loword = wParam And &HFFFF
    
    Select Case wMsg
    Case WM_MOUSEWHEEL [COLOR=green]' Ah, the mouswheel is in use
        ' This is where you control the scroll of the flexgrid, assuming you are over a flexgrid when this event happens
        ' e.g. check coords held in lParam against flexgrid[/color]
        
        [COLOR=red][b]Set mygrid = FlexGridFromPoint(lParam And &H7FFF, lParam \ &H10000)
        If Not mygrid Is Nothing Then[/b][/color]
            Select Case Sgn(myWParam.Hiword)
            Case 1:    
                If [b][COLOR=red]mygrid[/color][/b].TopRow > 1 Then [b][COLOR=red]mygrid[/color][/b].TopRow = [b][COLOR=red]mygrid[/color][/b].TopRow - 1
            Case -1:   
                [b][COLOR=red]mygrid[/color][/b].TopRow = [b][COLOR=red]mygrid[/color][/b].TopRow + 1
            End Select
        [COLOR=red][b]End If[/b][/color]
    Case Else
        MWheelProc = CallWindowProc(hOldWheelProc, hWnd, wMsg, wParam, lParam)
    End Select
End Function

[COLOR=red][b]Private Function FlexGridFromPoint(x As Long, y As Long) As MSFlexGrid
    Dim candidate As Control
    For Each candidate In Form1.Controls
        If TypeName(candidate) = "MSFlexGrid" Then
            If WindowFromPoint(x, y) = candidate.hWnd Then Set FlexGridFromPoint = candidate
        End If
    Next
End Function[/b][/color][/color]

 

[sal21]

STRONG!!!!
Tks, as usual, gentlemen!

and for the great code!