APIs: Se synchroniser avec la roulette de la souris IntelliMouse	Author(s) 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 utilisant 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  résultat,
'        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. Le 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 ***************