API: Track IntelliMouse's Wheel

Note: In order to test the code in this article, you will need the AddressOf code as well.

    In Access 97, the IntelliMouse's wheel has the effect of paging through records. Often times, it might be necessary to track how many records, forward or backward, the user has moved by using the wheel. By registering a custom callback function which runs whenever the wheel is moved, we can determine when the wheel is activated, and get the number of "ticks" that the wheel has processed.

Save the frmMouseWheel.txt file to your hard disk. Then, load this text file as a new form by using the LoadFromText method from the Debug window in a new database.

call Application.LoadFromText(acForm,"frmMouseWheel","F:\website\frmMouseWheel.txt")

where "f:\website" is the location of the text file containing the following code on my machine.

Place this code in a new module and compile and Save all Modules.

'*********** Code Start ************
'Note that this code has been modified to run in VBA (Access) using the addrOf function
'
'Code courtesy of Tim Kilgore @ http://www.missouri.edu/~finaidtk/index.html
'His comments reproduced below:
'        Starting in late 1996, Microsoft began deliving the new Intellimouse.
'        This mouse is notable, because it comes with a small wheel located
'        between the two buttons. This wheel is generally used by applications
'        to allow the user to scroll up and down documents.
'
'        As this style of mouse becomes more common, it will become
'        increasingly important to provide some degree of support for the
'        Intellimouse wheel. Already Gateway 2000 is shipping the Intellimouse
'        with new PCs, and doubtlessly other manufacturers are or will ship the
'        Intellimouse or clones which emulates it's functionality.
'
'        At the time of this writing, VB5 does not directly support the
'        Intellimouse. Microsoft does, however, provide documentation for
'        accessing the mouse in Active Visual Basic 5.0 (Eddon & Eddon, 1997
'        Microsoft Press, isbn 1-57231-512-1). The example provided by this
'        tome details how to create an ActiveX control which traps Intellimouse
'        wheel events.
'
'        The example contained in this web document is geared for inclusion
'        into a standard EXE project. As a result, it should work well with either
'        VB5 or VB4. I choose this approach because a simple example without
'        the concerns of ActiveX programming is needed.
' Important
'   Note
'        Windows NT provides native support for the Intellimouse. As a result,
'        the methods described here probably will not work with NT 4.0 or
'        better. Not having NT 4.0, I cannot test this first hand. The CD included
'        With Eddon 's book does detail how this is done.
' Code Starts
'   Here
'
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
'Register a custom callback message when the wheel moves
       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
'This is the actual callback function which gets called when a message is received. Note thet
'it has to determine if the message is the desired one.
'All messages then get passed on to the next hook
'It appears that Access UI gets all the messages first, so it is not possible to cause
'Access to not react to the mouse wheel itself.

           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

'        Because this codes hooks into the windows messaging system, you
'        should not use the IDE's STOP button to terminate the execution of your
'        code. Closing the form normally is mandatory. Debugging will become
'        difficult once you have hooked the mouse messages, so I recommend
'        adding Intellimouse support after the bulk of your programming work
'        has been completed. As with any serious API programming tasks, you
'        should save your project before execution.
'
'        I do not know if it will apply to this particular subclassing method, but
'        the Visual Basic Programmer's Journal's website (DevX) reportedly has
'        a DLL that can be added to a project at runtime that will help you work
'        around limitations related to subclassing.
'        One of the nice features of the intellimouse hook, is that it returns both
'        the X and Y coordinates (in pixels) of where the mouse was at when
'        the wheel was moved. This means that, with a little API work, you can
'        perform different actions based upon where the mouse is located. You
'        should be able to add scrolling support to multiple controls, though I
'        recommend defining a default control in the event that the mouse is not
'        located over anything that can be scrolled.
'
'        If you develop a working model that supports both NT and Win95,
'        please let me know so I can include the missing code.

'
'

Public Function GetWindowDesc$(hwnd&)
    Dim desc$
    Dim tbuf$
    Dim inst&   ' Now a long
    Dim dl&
    Dim hWndProcess&

    ' Include the windows handle first
    desc$ = "&H" + Hex$(hwnd) + Chr$(9)

    ' Get name of source app
    tbuf$ = String$(256, 0) ' Predefine string length
    
    ' Handling of process is different in Win32 - see text
    dl& = GetWindowThreadProcessId(hwnd, hWndProcess)
    If hWndProcess = GetCurrentProcessId() Then
        ' Get instance for window
        ' Was: inst% = GetWindowWord(hwnd%, GWW_HINSTANCE)
        
        inst& = GetWindowLong(hwnd&, GWL_HINSTANCE)
        ' Get the module filename
        ' Was: dummy% = GetModuleFileName(inst%, tbuf$, 255)
        dl& = GetModuleFileName(inst, tbuf$, 255)
    
        tbuf$ = GetBaseName(tbuf$)

        ' The following two lines are equivalent
        'tbuf$ = agGetStringFromLPSTR$(tbuf$)
         If InStr(tbuf$, Chr$(0)) Then tbuf$ = Left$(tbuf$, InStr(tbuf$, Chr$(0)) - 1)
    Else
        tbuf$ = "Foreign Window"
    End If
    
    ' And add it to the description
    desc$ = desc$ + tbuf$ + Chr$(9)

    ' Finally, add the class name
    tbuf$ = String$(256, 0) ' Initialize space again
    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$

    ' And return the description
    GetWindowDesc$ = desc$

End Function

' If source$ is a path, this function retrieves the
' basename, or filename sans path
' source$ MUST be a valid filename
'
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 ***************