--- 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 ***************