Attribute VB_Name = "modWheelMouse"
Option Explicit


'=============================================================================================================
'
' modWheelMouse Module
' --------------------
'
' Created By  : Kevin Wilson
'               http://www.TheVBZone.com   ( The VB Zone )
'               http://www.TheVBZone.net   ( The VB Zone .net )
'
' Last Update : June 06, 2000
'
' VB Versions : 5.0 / 6.0
'
' Requires    : A Microsoft Intellimouse (or compatible wheel mouse)
'
' Description : This module was created to make it possible to easily trap mouse wheel events that are sent
'               to the specified form.
'
' Note        : This module can be used for multiple forms if:
'               1) The Mouse_Form and Mouse_Control variables are set and the Mouse_HookForm function is called
'               from within the Form_Activate() event.  The Form_Activate event is fired when the focus is
'               passed back and forth between different forms within the same project.
'               2) The process done in the Mouse_MessageProc is a PUBLIC process that is not specific to any
'               one form.
'
' WARNING     : Failure to unhook a window before its imminent destruction may result in application errors,
'               Invalid Page Faults, and data loss.  This is due the fact that the new WindowProc function
'               being pointed to no longer exists, but the window has not been notified of the change.
'               Always unhook the sub-classed window upon unloading the sub-classed form or exiting the
'               application. This is especially important while debugging an application that uses this
'               technique within the Microsoft Visual Basic Development Environment (IDE).  Pressing the END
'               button or selecting END from the Run menu without unhooking may cause an Invalid Page Fault
'               and close Microsoft Visual Basic.  Changes to the active project will be lost.
'
' See Also    : http://support.microsoft.com/support/kb/articles/Q231/4/65.ASP
'               http://www.microsoft.com/products/hardware/mouse/intellimouse/sdk/sdkmessaging.htm
'
' Example Use :
'
'  Private Sub Form_Load()
'    Set Mouse_Form = Me
'    Set Mouse_Control = Picture1
'    Mouse_ShowDebug = False
'    Mouse_HookForm Me.hwnd
'  End Sub
'
'  Private Sub Form_Unload(Cancel As Integer)
'    Mouse_UnhookForm Me.hwnd
'  End Sub

'
'=============================================================================================================
'
' LEGAL:
'
' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit
' given where credit is due.  Also, it is not required, but it would be appreciated if you would mention
' somewhere in your compiled program that that your program makes use of code written and distributed by
' Kevin Wilson (www.TheVBZone.com).  Feel free to link to this code via your web site or articles.
'
' You may NOT take this code and pass it off as your own.  You may NOT distribute this code on your own server
' or web site.  You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products,
' utilities, or applications that directly compete with products, utilities, and applications created by Kevin
' Wilson, TheVBZone.com, or Wilson Media.  You may NOT take this code and sell it for profit without first
' obtaining the written consent of the author Kevin Wilson.
'
' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without
' warning or notice.  Copyright© by Kevin Wilson.  All rights reserved.
'
'=============================================================================================================


' Declare Types / Enumerations
Private Type OSVERSIONINFO
  dwOSVersionInfoSize As Long
  dwMajorVersion      As Long
  dwMinorVersion      As Long
  dwBuildNumber       As Long
  dwPlatformId        As Long
  szCSDVersion        As String * 128 '  Maintenance string for PSS usage
End Type

Private Enum OSTypes
  OS_Unknown = 0     ' "Unknown"
  OS_Win32 = 32      ' "Win 32"
  OS_Win95 = 95      ' "Windows 95"
  OS_Win98 = 98      ' "Windows 98"
  OS_WinNT_351 = 351 ' "Windows NT 3.51"
  OS_WinNT_40 = 40   ' "Windows NT 4.0"
  OS_Win2000 = 2000  ' "Windows 2000"
End Enum

' Constants
Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const GWL_WNDPROC = (-4)
Private Const SM_MOUSEWHEELPRESENT = 75
Private MSWHEEL_ROLLMSG As Long ' Variable constant value

' Variables to hold the Operating System's information
Private Win_OS          As OSTypes
Private Win_Version     As String
Private Win_Build       As String
Private CantGetOSInfo   As Boolean

' Variables to hold hook information
Private CheckedWheel    As Boolean
Private WheelExists     As Boolean
Private PreviousWndProc As Long
Private PreviousHWND    As Long

' Variables that return information about the mouse
Public Mouse_X          As Integer
Public Mouse_Y          As Integer
Public Mouse_RollUp     As Boolean
Public Mouse_ShowDebug  As Boolean
Public Mouse_Control    As Control
Public Mouse_Form       As Form

' Windows API Declarations
Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function CallWindowProc Lib "USER32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function RegisterWindowMessage Lib "USER32" Alias "RegisterWindowMessageA" (ByVal LPString As String) As Long
Private Declare Function GetVersionEx Lib "KERNEL32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetSystemMetrics Lib "USER32" (ByVal nIndex As Long) As Long

' Function that subclasses the specified form to trap mouse events
Public Function Mouse_HookForm(ByVal FormHandle As Long)
On Error Resume Next
  
  ' Check if there's a wheel mouse present
  ' (NOTE - This only checks if a mouse is present once)
  If CheckedWheel = True And WheelExists = False Then
    Exit Function
  ElseIf CheckedWheel = True And WheelExists = True Then
    DoEvents
  ElseIf CheckedWheel = False Then
    If Mouse_CheckForWheel = True Then
      CheckedWheel = True
      WheelExists = True
    Else
      CheckedWheel = True
      WheelExists = False
      Exit Function
    End If
  End If
  
  ' If there was a previously sublcassed form, release it so as to avoid problems
  If PreviousHWND <> 0 Then
    Mouse_UnhookForm PreviousHWND
    DoEvents
  End If
  
  ' Check the operating system
  ' (NOTE - This only checks the OS once, and if it fails doesn't try again)
  If Win_OS = OS_Unknown And CantGetOSInfo = False Then
    If GetOS = False Then
      CantGetOSInfo = True
    End If
  End If
  
  ' Set the windows message to look for in the sublcass event
  If Win_OS = OS_Win98 Or Win_OS = OS_WinNT_40 Or Win_OS = OS_Win2000 Then
    MSWHEEL_ROLLMSG = &H20A
  Else
    MSWHEEL_ROLLMSG = RegisterWindowMessage("MSWHEEL_ROLLMSG")
  End If
  
  ' Set "Mouse_MessageProc" as the new message handling function... and at
  ' the same time, record what the previous message handler was.
  PreviousWndProc = SetWindowLong(FormHandle, GWL_WNDPROC, AddressOf Mouse_MessageProc)
  
  ' Set the last form hooked for unhook later
  PreviousHWND = FormHandle
  
End Function

' Function that releases the specified form from the subclass
Public Function Mouse_UnhookForm(ByVal FormHandle As Long)
On Error Resume Next
  
  If FormHandle <> 0 Then
    SetWindowLong FormHandle, GWL_WNDPROC, PreviousWndProc
  End If
  
End Function

' Function that checks for a wheel mouse
Public Function Mouse_CheckForWheel() As Boolean
On Error Resume Next
  
  ' Check for wheel mouse on Win98, WinNT 4.0, & Win2000
  If GetSystemMetrics(SM_MOUSEWHEELPRESENT) Then
    Mouse_CheckForWheel = True
  
  ' Check for wheel mouse on Win32's, Win95, & WinNT 3.5x
  ElseIf FindWindow("MouseZ", "Magellan MSWHEEL") <> 0 Then
    Mouse_CheckForWheel = True
  
  ' Wheel mouse not found
  Else
    Mouse_CheckForWheel = False
  End If
  
End Function

' Function designed to let you know if the mouse is currently within the bounds of
' the specified control on the specified form.
' NOTE - This function assumes that the specified control's parent is the specified
'        form _OR_ the specified control is within another control who's parent
'        is the specified form.
Private Function Mouse_InBounds(ByVal TheForm As Object, ByVal TheControl As Control) As Boolean
On Error Resume Next
  
  Dim TitlebarHeight As Long
  Dim ControlLeft As Long
  Dim ControlTop As Long
  Dim ControlHeight As Long
  Dim ControlWidth As Long
  
  ' Get the height of the form's titlebar
  TitlebarHeight = TheForm.Height - TheForm.ScaleHeight
  
  ' Get the left and top coordinates of the control
  If TheControl.Parent = TheForm Then ' Control's parent is the form
    ControlLeft = TheForm.Left + TheControl.Left
    ControlTop = TheForm.Top + TheControl.Top + TitlebarHeight
  Else                                ' The control's parent is another control
    ControlLeft = TheForm.Left + TheControl.Parent.Left + TheControl.Left
    ControlTop = TheForm.Top + TheControl.Parent.Top + TheControl.Top + TitlebarHeight
  End If
  ControlHeight = TheControl.Height
  ControlWidth = TheControl.Width
  
  ' If the ScaleMode is TwipsPerPixel, adjust the measurements accordingly
  If TheForm.ScaleMode = vbTwips Then
    ControlLeft = ControlLeft / Screen.TwipsPerPixelX
    ControlTop = ControlTop / Screen.TwipsPerPixelY
    ControlWidth = TheControl.Width / Screen.TwipsPerPixelX
    ControlHeight = TheControl.Height / Screen.TwipsPerPixelY
  End If
  
  ' Check if the mouse is within the specified object / control
  If Mouse_X > ControlLeft And _
     Mouse_X < ControlLeft + ControlWidth And _
     Mouse_Y > ControlTop And _
     Mouse_Y < ControlTop + ControlHeight Then
    Mouse_InBounds = True
  Else
    Mouse_InBounds = False
  End If
  
End Function

' This is the subclassing function where vents are passed to
Public Function Mouse_MessageProc(ByVal hWnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
  
  ' Show the messages being passed to the process
  If Mouse_ShowDebug = True Then
    Debug.Print "hwnd=" & CStr(hWnd) & ", msg=" & CStr(MSG) & ", wParam=" & CStr(wParam) & ", lParam=" & CStr(lParam)
  End If
  
  ' Process the messages
  Select Case MSG
    Case MSWHEEL_ROLLMSG ' Mouse wheel event
      
      ' Set the current mouse X and Y coordinates
      Mouse_X = lParam And 65535
      Mouse_Y = lParam \ 65535
      
      ' Return if the mouse wheel was rolled up or down
      If wParam > 0 Then
        Mouse_RollUp = True
      Else
        Mouse_RollUp = False
      End If
      
      ' If the user specified a control and the form, then check if the
      ' mouse is within the bounds of that control.  If it's not within
      ' the specified control's bounds, exit out of this routine.
      If Not Mouse_Control Is Nothing And Not Mouse_Form Is Nothing Then
        If Mouse_InBounds(Mouse_Form, Mouse_Control) = False Then
          GoTo Finished
        End If
      End If
      
'******************************************************************************
'            PUT YOUR CODE HERE TO PROCESS THE MOUSE WHEEL EVENT
'                                     OR
'          CALL A FUNCTION HERE THAT PROCESS THE MOUSE WHEEL EVENT
'******************************************************************************
      
      Debug.Print "  ********** FIRE EVENT !  **********"
      
'******************************************************************************
      
  End Select
  
Finished:
  
  ' Allow the messages to continue to where they are supposed to go
  Mouse_MessageProc = CallWindowProc(PreviousWndProc, hWnd, MSG, wParam, lParam)
  
End Function


'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX


' Function to set the windows information variables
Private Function GetOS() As Boolean
On Error GoTo TheEnd
  
  Dim OSinfo As OSVERSIONINFO
  Dim RetValue As Long
  Dim PID As String
  
  OSinfo.dwOSVersionInfoSize = 148
  OSinfo.szCSDVersion = Space(128)
  RetValue = GetVersionEx(OSinfo)
  If RetValue = 0 Then
    Win_Build = ""
    Win_OS = OS_Unknown
    Win_Version = ""
    GetOS = False
    Exit Function
  End If

  With OSinfo
    Select Case .dwPlatformId
      Case VER_PLATFORM_WIN32s
        PID = "Win 32"
        Win_OS = OS_Win32
      Case VER_PLATFORM_WIN32_WINDOWS
        If .dwMinorVersion = 0 Then
          PID = "Windows 95"
          Win_OS = OS_Win95
        ElseIf .dwMinorVersion = 10 Then
          PID = "Windows 98"
          Win_OS = OS_Win98
        End If
      Case VER_PLATFORM_WIN32_NT
        If .dwMajorVersion = 3 Then
          PID = "Windows NT 3.51"
          Win_OS = OS_WinNT_351
        ElseIf .dwMajorVersion = 4 Then
          PID = "Windows NT 4.0"
          Win_OS = OS_WinNT_40
        ElseIf .dwMajorVersion = 5 Then
          PID = "Windows 2000"
          Win_OS = OS_Win2000
        End If
      Case Else
        PID = "Unknown"
        Win_OS = OS_Unknown
    End Select
  End With
  
  Win_Version = Trim(Str(OSinfo.dwMajorVersion) & "." & LTrim(Str(OSinfo.dwMinorVersion)))
  Win_Build = Trim(Str(OSinfo.dwBuildNumber))
  
  GetOS = True
  
  Exit Function
  
TheEnd:
  
  Err.Clear
  GetOS = False
  
End Function