--- Soumis par Larry Christopher---
Se synchroniser avec la roulette de la souris IntelliMouse.
Note: Pour tester le code de cet article, vous devez avoir également le code pour AddressOf.
Sous Access 97, la roulette de la souris Intellimouse parcourt les enregistrements. Parfois, il est nécessaire de connaître le nombre d'enregistrement qu'on a sauté, par en avant ou par en arrière, lorsque l'usager utilise la roulette. En enregistrant une fonction spéciale à cette effet, par sous-classement, qui s'active à chaque utilisation de la roulette, on détermine non seulement le moment de l'utilisation, mais également le nombre de "declick" que la roulette a enregistrée.
Sauvegarder le fichier frmMouseWheel.txt sur votre disque. Puis, charger ce fichier en tant que nouveau formulaire en utilisatn la méthode LoadFromText depuis la fenêtre d'exécution immédiate (Debug WIndow) dans une nouvelle base de données:
call Application.LoadFromText(acForm,"frmMouseWheel","F:\website\frmMouseWheel.txt")
où "f:\website" est la localisation du fichier texte, dans votre case, contenant le code suivant.
Placer le code dans un nouveau module, puis, compiler et sauvegarder tous les modules.
'*********** Code Start ************ 'Note: ce code fut modifié pour fonctionner sous VBA (Access) en utilisant addrOf ' 'Code courtesy of Tim Kilgore @ http://www.missouri.edu/~finaidtk/index.html 'Une traduction de ses commentaires sont reproduits ci-dessous: ' Depuis la fin de 1996, Microsoft livre sa nouvelle souris Intellimouse. ' Cette souris est remarquable de par sa roulette sise ' entre les deux boutons. Cette roulette est généralement utilisée par les ' applications permettant un défilement vertical sans bouger la souris. ' ' Ce type de souris devenant de plus en plus populaire, il importe ' de supporter de quelque façon cette roulette de souris ' Intellimouse, Déjà, Gateway 2000 fournit cette souris ' avec ses nouveaux PCs, et probablement les autres manufacturiers ' emboîteront le pas avec une Intellimouse, ou quelques clones. ' ' Au moment d'écrire ces lignes, VB5 ne supporte pas directement ' l'Intellimouse. Microsoft, par contre, fournit l'information permettant ' d'accéder à la souris depuis Visual Basic 5.0 (Eddon & Eddon, 1997 ' Microsoft Press, isbn 1-57231-512-1). L'exemple donné dans ce bouquin ' montre les détails pour créer un contrôle ActiveX qui capture les événements ' de la roulette. ' ' L'exemple inclus ici s'oriente pour une inclusion dans un projet standard ' de type exécutable (EXE). Il devrait donc fonctionner bien et ce, tant sous ' VB5 que sous VB4. J'ai choisi cette approche car un exemple simple, sans être ' concerné des paradigmes propres aux contrôles ActiveX semblait requise. ' Importante ' Note ' Windows NT ne présente pas de support, nativement, pour l' Intellimouse. En resultat, ' les méthodes décrites ici ne fonctionneront probablement PAS sous NT 4.0 ou ' plus récent. Ne possédant pas NT 4.0, je ne peux personnellement le tester. The CD accompagnant ' le bouquin de Eddon présente des détails pour le faire. ' Le code commence ' Ici ' Public Declare Function CallNextHookEx& Lib "user32" (ByVal hHook As Long, _ ByVal nCode As Long, ByVal wParam As Integer, lParam As Any) Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long Public Declare Function RegisterWindowMessage& Lib "user32" Alias "RegisterWindowMessageA" _ (ByVal lpString As String) Public Declare Function SetWindowsHookEx& Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _ ByVal dwThreadId As Long) Public Declare Function UnhookWindowsHookEx& Lib "user32" (ByVal hHook As Long) Public Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, _ lpPoint As POINTAPI) As Long Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, _ ByVal yPoint As Long) As Long Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, _ lpdwProcessId As Long) As Long Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" _ (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long Public Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _ ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Public Type POINTAPI X As Long Y As Long End Type Public Type MSG hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type Public IMWHEEL_MSG As Long Public HWND_HOOK As Long Public Const WH_GETMESSAGE = 3 Public Const MSH_MOUSEWHEEL = "MSWHEEL_ROLLMSG" Public Const GWL_HINSTANCE = (-6) ' ' Public Function IMWheel_Hook() As Long 'Enregistrer son proppre message de callback pour une activation de la roulette IMWHEEL_MSG = RegisterWindowMessage(MSH_MOUSEWHEEL) HWND_HOOK = SetWindowsHookEx(WH_GETMESSAGE, AddrOf("IMWheel"), 0, _ GetCurrentThreadId) End Function Public Sub IMWheel_Unhook() UnhookWindowsHookEx HWND_HOOK End Sub Function IMWheel(ByVal nCode As Long, ByVal wParam As Long, lParam As MSG) As Long 'Voici la fonction du callback, elle est appelée lorsque le message est reçu. Noter que 'elle doit déterminer si le message est celui qu'elle traite. 'Tous les messages sont ré-accrochés à la boucle. 'Il semble que l'interface usager d'Access obtienne les messages en premier, il semble improbable donc 'que Access ne réagisse pas à la roulette de la souris. If lParam.message = IMWHEEL_MSG Then Call Forms.frmMouseWheel.WheelMoved(lParam.wParam, lParam.pt.X, lParam.pt.Y) End If IMWheel = CallNextHookEx(HWND_HOOK, nCode, wParam, lParam) End Function ' Parce que ce code s'insère à l'intérieur de la boucle de messges de WINDOWS, ' vous ne devez pas utilise le bouton STOP de l'interface de DEBUG pour terminer ' l'exécution de ce code. Fermer le formulaire nomalement est requis. Déverminer deviendra ' plus dificile lorsque vous vous serez inséré dans les messages de souris, aussi, je recommande ' d'installer le support pour l' Intellimouse lorsque le gros du travail de programmation aura été ' complété. De plus, comme tout aventure avec l'API, je vous suggère de sauvegarder votre ' projet avant de l'exécuter. ' ' J'ignore si c'est applicable à cette méthode de sous-classement, mais ' le site Visual Basic Programmer's Journal's (DevX) aurait un DLL qui pourait ' s'ajouter à votre projet pour vous aider, en mode runtime, contre les limitations ' reliées au sous-classement. ' Un des points intéressants de l'Intellimouse, c'est le retour des deux coordonnées ' X et Y (en pixels) de la souris lorsque la roulette fut actionnée. ' En effet, avec un peu de travail API, on peut envisager d'entreprendre diverses ' actions dépendamment de la position de la souris. On devrait être capable de ' supporter un défilement pour divers contrôles, même si je recommande un ' contrôle par défaut au cas où la souris ne serait sur rien de défilable. ' ' Si vous travailler su un model supportant à la fois NT et Win95, ' laissez le moi savoir de sorte que je puisse insérer le code manquant. ' ' Public Function GetWindowDesc$(hwnd&) Dim desc$ Dim tbuf$ Dim inst& ' Pas un type long Dim dl& Dim hWndProcess& ' Inclure les poignées de windows tout d'abord desc$ = "&H" + Hex$(hwnd) + Chr$(9) ' Obtenir le nom de l'application mère tbuf$ = String$(256, 0) ' Chaîne de longueur fixe ' Processus différent en Win32 - voir le texte dl& = GetWindowThreadProcessId(hwnd, hWndProcess) If hWndProcess = GetCurrentProcessId() Then ' Obtenir l'instance de window ' Was: inst% = GetWindowWord(hwnd%, GWW_HINSTANCE) inst& = GetWindowLong(hwnd&, GWL_HINSTANCE) ' Obtenir le nom du fichier du module ' Was: dummy% = GetModuleFileName(inst%, tbuf$, 255) dl& = GetModuleFileName(inst, tbuf$, 255) tbuf$ = GetBaseName(tbuf$) ' Les deux lignes suivantes sont équilvalentes 'tbuf$ = agGetStringFromLPSTR$(tbuf$) If InStr(tbuf$, Chr$(0)) Then tbuf$ = Left$(tbuf$, InStr(tbuf$, Chr$(0)) - 1) Else tbuf$ = "Foreign Window" End If ' et ajouter la description desc$ = desc$ + tbuf$ + Chr$(9) ' et finalement, le nom de la classe tbuf$ = String$(256, 0) ' Initialiser l'espace, encore dl& = GetClassName(hwnd&, tbuf$, 255) 'tbuf$ = agGetStringFromLPSTR$(tbuf$) If InStr(tbuf$, Chr$(0)) Then tbuf$ = Left$(tbuf$, InStr(tbuf$, Chr$(0)) - 1) desc$ = desc$ + tbuf$ ' et retourner la description GetWindowDesc$ = desc$ End Function ' Si source$ est un chemin, la fonction décèle le nom ' de base, sans la portion du chemin. ' source$ DOIT être un nom de fichier valide ' Private Function GetBaseName$(ByVal source$) Do While InStr(source$, "\") <> 0 source$ = Mid$(source$, InStr(source$, "\") + 1) Loop If InStr(source$, ":") <> 0 Then source$ = Mid$(source$, InStr(source$, ":") + 1) End If GetBaseName$ = source$ End Function '***************** Code End ***************