Utilisation de la roulette centrale de la souris pour scroller un MSHFlexGrid

[ProgElecT]

Ce petit code permet de faire défiler les lignes d’un MSHFlexGrid à l’aide de la roue de la souris, chose impossible en natif.

Le code comprend 2 gestions distinctes.

Gestion N°1, purement pour l’utilisation de la roulette de souris
Dans le module.Bas,

détection des messages générés par la souris et quoi faire si la roue de la souris et mise en rotation.

Dans le Form,

sub Form_Initialize, Y a t il une roulette disponible ?

Dans un module.bas y placer ce

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
Option Explicit
 
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
    ByVal hwnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" ( _
    ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam 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
Public Declare Function GetProp Lib "user32" Alias "GetPropA" ( _
    ByVal hwnd As Long, _
    ByVal lpString As String) As Long
Public Declare Function SetProp Lib "user32" Alias "SetPropA" ( _
    ByVal hwnd As Long, _
    ByVal lpString As String, _
    ByVal hData As Long) As Long
Public Declare Function RemoveProp Lib "user32" Alias "RemovePropA" ( _
    ByVal hwnd As Long, _
    ByVal lpString As String) As Long
Public Declare Function GetSystemMetrics Lib "user32" ( _
    ByVal nIndex As Long) As Long
Private Const WM_MOUSEWHEEL = &H20A
Private Const WHEEL_DELTA = 120
 
'variable qui déterminera si on peut utilisé la roulette de la souris
Public OkRoulette As Boolean
 
Public Const GWL_WNDPROC = -4
Public Const SM_MOUSEWHEELPRESENT = 75
 
Public Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If uMsg = WM_MOUSEWHEEL Then
    If (HiWord(wParam) / WHEEL_DELTA) < 0 Then
        If Form1.VScroll1.Value + 1 <= Form1.VScroll1.Max Then Form1.VScroll1.Value = Form1.VScroll1.Value + 1
        Else
        If Form1.VScroll1.Value - 1 >= Form1.VScroll1.Min Then Form1.VScroll1.Value = Form1.VScroll1.Value - 1
    End If
    'Passez le message au procédé de fenêtre de défaut et puis sur le parent
    DefWindowProc hwnd, uMsg, wParam, lParam
    Else
    'Message manipulé, n'appelle pas le procédé original de fenêtre
    WndProc = CallWindowProc(GetProp(Form1.MSHFlexGrid1.hwnd, "PrevWndProc"), hwnd, uMsg, wParam, lParam)
End If
End Function
Public Function HiWord(dw As Long) As Integer
    If dw And &H80000000 Then
        HiWord = (dw \ 65535) - 1
    Else
        HiWord = dw \ 65535
    End If
End Function

Seules les lignes 42 et 44 sont de moi , le restant a été récupéré il y a un certains temps mais je ne sais plus ou, merci a son auteur.


Gestion N°2, défilement des lignes du MSHFlexGrid

Sub ParamScroolFlexGrid
compte les lignes possiblement visibles du MSHFlexGrid suivant sa hauteur de fenêtre,
plus paramétrage du Min et Max du VScrollBar
VScroll1 étant rendu invisible, c’est la fonction WndProc contenu dans le module.Bas
qui incrémente ou décrémente sa valeur

Sub VScroll1_Change
assure le défilement des lignes du MSHFlexGrid, soit vers le haut soit vers le bas.

Sur un Form, un MSHFlexGrid (Ctrl+T ---> et cocher Microsoft Hierarchical FlexGrid Control 6.0 (OLEDB)), un VScrollBar et 2 CommandButton puis ce

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
Option Explicit
'variables d'usage generales
Dim T As Long
Dim Ldeb As Long, LFin As Long
Dim NbrRowVisibl As Long
 
 
' *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*  Partie utile pour utilisation de la roulette souris *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
Private Sub Form_Initialize()
OkRoulette = False
VScroll1.Visible = False
If GetSystemMetrics(SM_MOUSEWHEELPRESENT) Then
    OkRoulette = True
    'Crée/enclenche, en tache de fond, la surveillance de la souris
    SetProp MSHFlexGrid1.hwnd, "PrevWndProc", SetWindowLong(MSHFlexGrid1.hwnd, GWL_WNDPROC, AddressOf WndProc)
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
If OkRoulette = True Then
    'pour mettre fin proprement à la routine utilisation de la roulette souris
    SetWindowLong MSHFlexGrid1.hwnd, GWL_WNDPROC, GetProp(MSHFlexGrid1.hwnd, "PrevWndProc")
    RemoveProp MSHFlexGrid1.hwnd, "PrevWndProc"
    Set Form1 = Nothing
End If
End Sub
' *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
 
 
 
 
'-----------------------------------------Routine ordinaire----------------------------------------
Private Sub Form_Load()
'placement des différents composants
MSHFlexGrid1.Move 540, 120, 2235, 3015
 
Command1.Left = MSHFlexGrid1.Left
Command1.Height = 555
Command1.Width = (MSHFlexGrid1.Width - 30) / 2
Command1.Caption = "...."
Command1.ToolTipText = "Cliquez moi pour faire perdre le focus de MSHFlexGrid1"
 
Command2.Left = Command1.Left + Command1.Width + 15
Command2.Height = Command1.Height
Command2.Width = Command1.Width
Command2.Caption = "Remplis le grid"
 
'Histoire de remplir une première fois le MSHFlexGrid
Ldeb = 47: LFin = 122
MSHFlexGrid1.Rows = (LFin - Ldeb) + 1: MSHFlexGrid1.Cols = 2
For T = Ldeb To LFin
    If T = Ldeb Then
        MSHFlexGrid1.TextMatrix(T - Ldeb, 0) = "Col1"
        MSHFlexGrid1.TextMatrix(T - Ldeb, 1) = "Col2"
        Else
        MSHFlexGrid1.TextMatrix(T - Ldeb, 0) = T - Ldeb
        MSHFlexGrid1.TextMatrix(T - Ldeb, 1) = Chr(T)
    End If
Next T
Me.Height = 4470: Me.Width = 3390
'rend le Form visible de façon a donner le focus au grid
Me.Visible = True
MSHFlexGrid1.SetFocus
End Sub
Private Sub Form_Resize()
'pour le cas ou vous désirez redimensionner le MSHFlexGrid
If Me.WindowState <> vbMinimized And Me.Visible = True Then
    'redimensionnement du MSHFlexGrid1 et repositionnement des 2 CommandButton
    If Me.Height >= 1980 Then
        Command1.Top = Me.ScaleHeight - Command1.Height - 90
        Command2.Top = Command1.Top
        MSHFlexGrid1.Height = Command1.Top - (MSHFlexGrid1.Top + 45)
        'il faut donc reparamétrer
        ParamScroolFlexGrid MSHFlexGrid1, VScroll1
    End If
End If
End Sub
Private Sub ParamScroolFlexGrid(HFlexGridMS As MSHFlexGrid, Vscrol As VScrollBar)
'Comptage du nombre de lignes visibles dans la fenêtre du MSHFlexGrid
Dim Cpt As Long
NbrRowVisibl = -1
For Cpt = 0 To HFlexGridMS.Rows - 1
    If NbrRowVisibl = -1 Then
        If HFlexGridMS.RowIsVisible(Cpt) = False Then
            NbrRowVisibl = Cpt
        End If
    End If
Next Cpt
'Paramétrage du VScroll
Vscrol.Max = HFlexGridMS.Rows + 1
Vscrol.Min = NbrRowVisibl
Vscrol.Value = (MSHFlexGrid1.TopRow + NbrRowVisibl) - 1
End Sub
Private Sub MSHFlexGrid1_Scroll()
'si NbrRowVisibl = -1 c'est que la fenêtre MSHFlexGrid affiche toutes les lignes,
'donc pas besoin d'actualiser VScroll1.
If NbrRowVisibl = -1 Then Exit Sub
'pour calage/actualisation de VScroll1
VScroll1.Value = (MSHFlexGrid1.TopRow + NbrRowVisibl) - 1
If Me.ActiveControl.Name <> "MSHFlexGrid1" Then
    MSHFlexGrid1.SetFocus
End If
End Sub
 
'Ce qu'il doit se passer quand il y a modification de la valeur du VScrollBar déclenché par la
'la fonction WndProc du module.bas
Private Sub VScroll1_Scroll()
VScroll1_Change
End Sub
Private Sub VScroll1_Change()
'si NbrRowVisibl = -1 c'est que la fenêtre MSHFlexGrid affiche toutes les lignes,
'donc pas besoin d'actualiser VScroll1.
If NbrRowVisibl = -1 Then Exit Sub
'petite assurence, des fois ....
'On Error Resume Next
MSHFlexGrid1.TopRow = (VScroll1.Value - NbrRowVisibl) + 1
End Sub
 
Private Sub Command2_Click()
'Histoire de remplir le MSHFlexGrid (BIS)
'pour illustrer le reparametrage de VScroll1
Ldeb = 65: LFin = 90
MSHFlexGrid1.Rows = (LFin - Ldeb) + 1
For T = Ldeb To LFin
    If T = Ldeb Then
        MSHFlexGrid1.TextMatrix(T - Ldeb, 0) = "Col1"
        MSHFlexGrid1.TextMatrix(T - Ldeb, 1) = "Col2"
        Else
        MSHFlexGrid1.TextMatrix(T - Ldeb, 0) = T - Ldeb
        MSHFlexGrid1.TextMatrix(T - Ldeb, 1) = Chr(T)
    End If
Next T
MSHFlexGrid1.Row = 1: MSHFlexGrid1.TopRow = 1
ParamScroolFlexGrid MSHFlexGrid1, VScroll1
End Sub
'-------------------------------------------------------------------------------------------------