Gestion de la roulette de la souris dans les formulaires

Date de publication : 15/04/06 , Date de mise à jour : 15/04/06

Par Thierry GASPERMENT (arkham46.developpez.com/)

Gestion de la roulette de la souris dans les formulaires.
Ajoutez un événement MouseWheel à vos formulaire et personnalisez l'action de la roulette.

Si possible, envisagez l'utilisation de la dll MouseWheelDVPNoReg pour un déploiement plus aisé.

Version PDF (Miroir) Version hors-ligne (Miroir)

I. Introduction
II. La librairie dll fournie par Microsoft
III. Référencer la librairie MouseWheelDVP?
III-A. Enregistrement dans Access
III-B. Enregistrement manuel
III-C. Enregistrement par le code VBA
III-D. Enregistrement de la librairie sous Windows 98
IV. Exploiter le nouvel événement MouseWheel
V. Exemple : bloquer l'action de la roulette
VI. Exemple : faire défiler le formulaire au lieu des enregistrements
VI. Exemple : faire défiler les zones de listes sous le curseur
VIII. Exemple : faire défiler une zone de texte mémo particulière
IX. Les téléchargements
X. Remerciements

I. Introduction

Utiliser la roulette de la souris dans un formulaire entraîne un changement d'enregistrement qui peut être indésirable.
En effet un utilisateur peut s'attendre à faire défiler le formulaire vers le bas, mais l'action sur la roulette de la souris passe à l'enregistrement suivant.
Cela peut être agaçant, voir très problématique car l'enregistrement est validé alors que l'utilisateur ne le souhaitait pas.

Pour pallier ce comportement on peut utiliser une librairie activeX qui va nous fournir un nouvel événement lors de l'action de la roulette

Envisager l'utilisation de la dll MouseWheelDVPNoReg pour un déploiement plus aisé.

II. La librairie dll fournie par Microsoft

Microsoft fourni ICI une dll qui permet d'annuler l'action de la roulette de la souris.
Malheureusement le code de cette dll n'est pas très fiable et ne fonctionne pas sur Access 2003.

Voici la liste des disfonctionnements que l'on a pû relever :
- incompatibilité avec Access 2003 (apparemment conflit de nom avec le nouvel événement Mousewheel);
- l'utilisation de la dll dans un sous-formulaire et son parent rend le sous-formulaire inaccessible;
- la fermeture du formulaire lors d'un aperçu avant impression fait crasher l'application;
- l'utilisation de la dll dans plusieurs formulaires est mal gérée, l'événement est renvoyé dans le dernier formulaire uniquement.
--> il n'est donc pas possible de conditionner l'action de la roulette dans les autres formulaires car ils ne reçoivent pas l'événement;

Et il manque à mon goût une information utile dans l'événement :
- dans quel sens a été déplacée la roulette? Cette information est utile si on désire exécuter une action spécifique.

C'est pour toutes ces raisons que j'ai développé une nouvelle librairie dll, baptisée pour l'occasion MouseWheelDVP.

III. Référencer la librairie MouseWheelDVP?

L'utilisation reste pratiquement identique à celle de la dll originale de Microsoft.

C'est une dll activeX, ce qui signifie qu'elle doit être enregistrée et que la référence doit être sélectionnée dans Access.

Attention : une fois enregistrée la dll ne doit pas changer d'emplacement.

Attention : Vous devez avoir les autorisations d'administration du poste pour pouvoir enregistrer la dll.

Si vous désirez changer la dll d'emplacement, désenregistrez la, puis référencez la à nouveau depuis le nouvel emplacement.

III-A. Enregistrement dans Access

Pour référencer la dll :
- allez dans l'éditeur VBA : Outils --> Macro --> Visual Basic Editor ; ou ALT+F11; ou Affichage --> Code sous Access 97
- allez dans le menu : Outils --> Références;
- cliquez sur le bouton parcourir et sélectionnez le fichier MouseWheelDVP.dll;
---> la librairie est automatiquement enregistrée dans le registre de Windows en suivant cette procédure.

III-B. Enregistrement manuel

- cliquez sur le menu Démarrer de Windows, puis Exécuter.
- tapez la commande suivante :
- pour enregistrer : regsvr32.exe C:\VotreChemin\MouseWheelDVP.dll
- pour désenregistrer : regsvr32.exe /u C:\VotreChemin\MouseWheelDVP.dll

Remarque : Il faut également cocher ou décocher la référence dans Access.

III-C. Enregistrement par le code VBA

Il est possible d'enregistrer la librairie avec des fonctions VBA.

Exemple de code à placer dans un module :

Fonctions d'enregistrement de librairies


Option Compare Database
Option Explicit

Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetLongPathName Lib "kernel32" Alias "GetLongPathNameA" _
                        (ByVal lpszShortPath As String, ByVal lpszLongPath As String, _
                         ByVal cchBuffer As Long) As Long

Private Declare Function DVPDllRegisterServer Lib "MouseWheelDVP" Alias "DllRegisterServer" () As Long
Private Declare Function DVPDllUnregisterServer Lib "MouseWheelDVP" Alias "DllUnregisterServer" () As Long
Private Declare Function DVPDllCanUnloadNow Lib "MouseWheelDVP" Alias "DllCanUnloadNow" () As Long

' Enregistre la librairie
Private Sub FnRegLib()
    Dim lLib As Long    ' Identifiant de la librairie
    Dim lReg As Long    ' Pointeur de la fonction d'enregistrement
    ' Référence la librairie dans Access
    On Error Resume Next ' si la librairie est déjà référencée on essaye quand même de l'enregistrer
    Application.References.AddFromFile ApplicationPath & "MouseWheelDVP.dll"
    On Error GoTo Gestion_Erreurs
    ' Charge la librarie
    lLib = LoadLibrary(ApplicationPath & "MouseWheelDVP.dll")
    If lLib = 0 Then
        MsgBox "Impossible de trouver la librairie :" & vbCrLf & ApplicationPath & "MouseWheelDVP.dll"
        Exit Sub
    End If
    ' Enregistre la librairie (en plus du AddFromFile qui parfois n'enregistre pas correctement la librairie)
    If DVPDllRegisterServer <> 0 Then
        MsgBox "Erreur lors du référencement de la librairie"
    End If
Gestion_Erreurs:
    If Err.Number <> 0 Then MsgBox Err.Description
    ' Libère la librairie
    FreeLibrary lLib
End Sub

' Désenregistre la librairie
Private Sub FnUnregLib()
    Dim lLib As Long        ' Identifiant de la librairie
    Dim lCanUnload As Long  ' Pointeur de la fonction de test d'utilisation de la dll
    Dim lUnReg As Long      ' Pointeur de la fonction d'enregistrement
    ' Supprime la référence dans Access
    On Error Resume Next ' si la librairie n'est pas référencée on essaye quand même de la désenregistrer
    Application.References.Remove Application.References.Item("MouseWheelDVP")
    On Error GoTo Gestion_Erreurs
    ' Charge la librarie
    lLib = LoadLibrary(ApplicationPath & "MouseWheelDVP.dll")
    If lLib = 0 Then
        MsgBox "Impossible de trouver la librairie :" & vbCrLf & ApplicationPath & "MouseWheelDVP.dll"
        Exit Sub
    End If
    ' Vérifie que la librairie n'est pas en cours d'utilisation
    If DVPDllCanUnloadNow <> 0 Then
        MsgBox "Impossible de déréférencer la librairie maintenant" & _
               vbCrLf & "Quittez les formulaires utilisant la librairie"
        GoTo Gestion_Erreurs
    End If
    ' Désenregistre la librairie (elle disparaît alors de la liste des références)
    If DVPDllUnregisterServer <> 0 Then
        MsgBox "Erreur lors du référencement de la librairie"
    End If
Gestion_Erreurs:
    If Err.Number <> 0 Then MsgBox Err.Description
    ' Libère la librairie
    FreeLibrary lLib
End Sub

' Récupère le chemin de l'application (chemin long)
' (pour remplacer CurrentProject.Path dans Access 97)
Public Function ApplicationPath() As String
    Dim lRet As Long
    Dim lShortPathName As String
    Dim lLongPathName As String
    lLongPathName = Space(1024)
    lShortPathName = Left(CurrentDb.Name, Len(CurrentDb.Name) - Len(Dir(CurrentDb.Name)))
    lRet = GetLongPathName(lShortPathName, lLongPathName, Len(lLongPathName))
    ApplicationPath = Left(lLongPathName, lRet)
End Function

Pour enregistrer la librairie qui se trouve dans le même répertoire que l'application :

Enregistrer la librairie


Call FnRegLib

Pour désenregistrer la librairie qui se trouve dans le même répertoire que l'application :

Désenregistrer la librairie


Call FnUnregLib

III-D. Enregistrement de la librairie sous Windows 98

Si vous êtes sous Windows 98 vous allez peut-être rencontrer quelques difficultés pour enregistrer la dll.
Celle-ci étant développée en VB6, installez le runtime VB6 pour pouvoir l'enregistrer.

IV. Exploiter le nouvel événement MouseWheel

Pour pouvoir accéder au nouvel événement, il faut créer un objet.
Cet objet est une instance du module de classe inclus dans la dll.
Il déclenchera un événement MouseWheel lorsqu'on utilise la roulette de la souris.

L'événement MouseWheel a trois paramètres :
- Cancel : annule simplement l'événement : la roulette n'a plus aucun effet
- FormScroll : renvoie l'événement au formulaire : ainsi on peut faire défiler un formulaire verticalement
- Delta : déplacement de la roulette par pas de 120 : 120 correspond à un déplacement de un pas vers le haut, -120 vers le bas

Code de base à mettre dans chacun des formulaires utilisant la dll


Option Compare Database
Option Explicit

Private WithEvents clMouseWHeel As MouseWheelDVP.CMouseWheel

Private Sub clMouseWHeel_MouseWheel(Cancel As Integer, FormScroll As Integer,Delta as Long)
' Ici on va spécifier ce que l'on veut faire lors de l'action sur la roulette
End Sub

Private Sub Form_Close()
    If Not (clMouseWHeel Is Nothing) Then
        Set clMouseWHeel = Nothing
    End If
End Sub

Private Sub Form_Load()
    Set clMouseWHeel = New MouseWheelDVP.CMouseWheel
    Set clMouseWHeel.Form = Me
End Sub

On notera qu'il ne faut pas oublier de libérer l'objet avant de quitter le formulaire.

V. Exemple : bloquer l'action de la roulette

Très simple il suffit d'affecter la valeur True au paramètre Cancel.

Bloquer l'action de la roulette


Option Compare Database
Option Explicit

Private WithEvents clMouseWHeel As MouseWheelDVP.CMouseWheel

Private Sub clMouseWHeel_MouseWheel(Cancel As Integer, FormScroll As Integer,Delta as Long)
' Annule l'action de la roulette
    Cancel = True
End Sub

Private Sub Form_Close()
    If Not (clMouseWHeel Is Nothing) Then
        Set clMouseWHeel = Nothing
    End If
End Sub

Private Sub Form_Load()
    Set clMouseWHeel = New MouseWheelDVP.CMouseWheel
    Set clMouseWHeel.Form = Me
End Sub

VI. Exemple : faire défiler le formulaire au lieu des enregistrements

Très simple aussi il suffit d'affecter la valeur True au paramètre FormScroll.
C'est fonctionnalité est très utile si vous avez un formulaire en mode simple qui est plus grand que la taille de l'écran.

Faire défiler le formulaire au lieu des enregistrements


Option Compare Database
Option Explicit

Private WithEvents clMouseWHeel As MouseWheelDVP.CMouseWheel

Private Sub clMouseWHeel_MouseWheel(Cancel As Integer, FormScroll As Integer,Delta as Long)
' Annule l'action de la roulette
    FormScroll = True
End Sub

Private Sub Form_Close()
    If Not (clMouseWHeel Is Nothing) Then
        Set clMouseWHeel = Nothing
    End If
End Sub

Private Sub Form_Load()
    Set clMouseWHeel = New MouseWheelDVP.CMouseWheel
    Set clMouseWHeel.Form = Me
End Sub

VI. Exemple : faire défiler les zones de listes sous le curseur

Ca se complique un peu plus...

On va :
- annuler le défilement standard avec Cancel = True
- utiliser l'API GetCursorPos pour récupèrer la position du curseur sur l'écran.
- utiliser l'API WindowFromPoint pour récupérer l'identifiant de la fenêtre sous le curseur.
- utiliser l'API GetClassName pour lire la classe de cette fenêtre
- vérifier que la fenêtre survolée est une zone de liste (classe oGrid)
- envoyer un événement à la liste pour la faire défiler

Remarque : Dans certaines versions d'Access, si une zone de liste (simple, donc non déroulante) a le focus alors l'événement MouseWheel n'est pas envoyé vers le formulaire, et donc le défilement de la liste ne fonctionne pas.
(En tout cas ça fonctionne avec Access 2003 mais pas avec Access 2000)

Faire défiler les zones de listes sous le curseur


Option Compare Database
Option Explicit

Private WithEvents clMouseWHeel As MouseWheelDVP.cMouseWheel

' Déclaration d'API
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, _
                                                       ByVal yPoint As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Type POINTAPI
    X As Long
    Y As Long
End Type
' Constantes pour le type de scrolling
Private Const WM_VSCROLL = &H115
' Constantes pour les commandes de scrolling
Private Const SB_LINEUP = 0
Private Const SB_LINEDOWN = 1

Private Sub clMouseWHeel_MouseWheel(Cancel As Integer, FormScroll As Integer, Delta As Long)
    ' Pour annuler l'événement
     Cancel = True
    ' Position du curseur
    Dim lpt As POINTAPI
    ' Fenêtre sous le curseur
    Dim lhWnd As Long
    ' Code retour de l'API
    Dim lRet As Long
    ' Classe de la fenêtre
    Dim lClassName As String
    ' Récupère la position du curseur
    Call GetCursorPos(lpt)
    ' Récupère l'identifiant de la fenêtre sous le curseur
    lhWnd = WindowFromPoint(lpt.X, lpt.Y)
    ' Recherche la classe de la fenêtre
    lClassName = Space(255)
    lRet = GetClassName(lhWnd, lClassName, 255)
    lClassName = Left(lClassName, lRet)
    ' Si la classe est oGrid alors le curseur est sur une zone de liste
    If lClassName = "oGrid" Then
    If Delta < 0 Then
        ' Déplacement vers le bas
        SendMessage lhWnd, WM_VSCROLL, SB_LINEDOWN, 0&
    Else
        ' Déplacement vers le haut
        SendMessage lhWnd, WM_VSCROLL, SB_LINEUP, 0&
    End If
    End If
End Sub

Private Sub Form_Close()
    If Not (clMouseWHeel Is Nothing) Then
        Set clMouseWHeel = Nothing
    End If
End Sub

Private Sub Form_Load()
    Set clMouseWHeel = New MouseWheelDVP.cMouseWheel
    Set clMouseWHeel.Form = Me
End Sub

VIII. Exemple : faire défiler une zone de texte mémo particulière

On utilise les API pour cet exemple également

On va :
- annuler le défilement standard avec Cancel = True
- vérifier que la zone de texte voulue est active (remplacer NomDeLaZoneDeTexte par le nom de votre zone de texte).
- utiliser l'API GetFocus pour récupèrer l'identifiant de la zone de texte.
- envoyer un événement à la zone de texte pour la faire défiler

faire défiler une zone de texte mémo particulière


Option Compare Database
Option Explicit

Private WithEvents clMouseWHeel As MouseWheelDVP.cMouseWheel

' Déclaration d'API
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetFocus Lib "user32" () As Long
' Constantes pour le type de scrolling
Private Const WM_VSCROLL = &H115
' Constantes pour les commandes de scrolling
Private Const SB_LINEUP = 0
Private Const SB_LINEDOWN = 1

Private Sub clMouseWHeel_MouseWheel(Cancel As Integer, FormScroll As Integer, Delta As Long)
    ' Pour annuler l'événement
     Cancel = True
    ' Fenêtre qui a le focus
    Dim lhWnd As Long
    ' Vérifie qu'on est sur le contrôle que l'on veut faire défiler
    On Error Resume Next
    If Screen.ActiveControl.Name <> "NomDeLaZoneDeTexte" Then Exit Sub
    If Err.Number <> 0 Then Exit Sub
    On Error GoTo 0
    ' Récupère l'identifiant de la fenêtre qui a le focus
    lhWnd = GetFocus
    If Delta < 0 Then
        ' Déplacement vers le bas
        SendMessage lhWnd, WM_VSCROLL, SB_LINEDOWN, 0&
    Else
        ' Déplacement vers le haut
        SendMessage lhWnd, WM_VSCROLL, SB_LINEUP, 0&
    End If
End Sub

Private Sub Form_Close()
    If Not (clMouseWHeel Is Nothing) Then
        Set clMouseWHeel = Nothing
    End If
End Sub

Private Sub Form_Load()
    Set clMouseWHeel = New MouseWheelDVP.cMouseWheel
    Set clMouseWHeel.Form = Me
End Sub

IX. Les téléchargements

Télécharger la dll (7Ko) (HTTP)
Télécharger le code source VB6 (11Ko) (HTTP)
Télécharger la base de test (Access 97) (21Ko) (HTTP)

X. Remerciements

Merci à Tofalu, Gaël Donat et FabienN pour leurs tests.

Version PDF (Miroir) Version hors-ligne (Miroir)

Les sources présentées sur cette page sont libres de droits, et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une oeuvre intellectuelle protégée par les droits d'auteurs. Copyright © Thierry GASPERMENT. Aucune reproduction, même partielle, ne peut être faite de ce site et de l'ensemble de son contenu : textes, documents, images, etc sans l'autorisation expresse de l'auteur. Sinon vous encourez selon la loi jusqu'à 3 ans de prison et jusqu'à 300 000 E de dommages et intérêts. Cette page est déposée à la SACD.