Attribute VB_Name = "modWheelMouse_OCX" Option Explicit '============================================================================================================= ' ' modWheelMouse_OCX Module ' ------------------------ ' ' Created By : Kevin Wilson ' http://www.TheVBZone.com ( The VB Zone ) ' http://www.TheVBZone.net ( The VB Zone .net ) ' ' Last Update : June 14, 2000 ' ' VB Versions : 5.0 / 6.0 ' ' Requires : MSGHOO32.OCX (MsgHook OLE Custom Control Module) ' 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 using the FreeWare ActiveX control "MSGHOO32.OCX". Using this control ' to process the messages sent to the specified form makes the VB IDE more stable when debugging ' code. When you sub-class a form to process the messages sent to it, it debugging the code ' very difficult and tends to crash the VB IDE if something goes wrong with the sub-class or ' if you forget to unsub-class the form. ' ' Example Use : ' ' Private Sub Form_Load() ' If Mouse_CheckForWheel = False Then ' MsgBox "No mouse wheel detected.", vbOKOnly + vbExclamation, " Wheel Missing" ' Else ' Set Mouse_Form = Me ' Set Mouse_Control = Picture1 ' Mouse_ShowDebug = False ' Mouse_InitWheel Me, True ' End If ' End Sub ' ' Private Sub Msghook1_Message(ByVal msg As Long, ByVal wp As Long, ByVal lp As Long, result As Long) ' On Error Resume Next ' ' ' Show the messages being passed to this sub if the user specifies to ' If Mouse_ShowDebug = True Then ' Debug.Print "msg = " & CStr(msg) & ", wParam = " & CStr(wp) & ", lParam = " & CStr(lp) & ", result = " & CStr(result) ' End If ' ' ' Set the current mouse X and Y coordinates ' Mouse_X = lp And 65535 ' Mouse_Y = lp \ 65535 ' ' ' Return if the mouse wheel was rolled up or down ' If wp > 0 Then ' Mouse_RollUp = True ' Else ' Mouse_RollUp = False ' End If ' ' ' Get the message passed to the form ' Select Case msg ' Case WM_SETTINGCHANGE ' Settings have changed ' ' Reset value of Mouse_ScrollLines ' Mouse_InitWheel Me ' ' Case Else ' Wheel has scrolled ' ' ' '******************************************************************* ' ' Put routine to execute or function to call here ' '******************************************************************* ' ' ' If use specified a control, check if mouse is within it's bounds ' If (Not Mouse_Control Is Nothing) And (Not Mouse_Form Is Nothing) Then ' If Mouse_InBounds(Mouse_Form, Mouse_Control) = True Then ' Debug.Print "************* FIRE EVENT ! ************* ' End If ' Else ' Debug.Print "************* FIRE EVENT ! ************* ' End If ' ' '******************************************************************* ' ' End Select ' ' 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 Public Const WM_SETTINGCHANGE = &H1A Private Const VER_PLATFORM_WIN32s = 0 Private Const VER_PLATFORM_WIN32_WINDOWS = 1 Private Const VER_PLATFORM_WIN32_NT = 2 Private Const SM_MOUSEWHEELPRESENT = 75 ' 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_ScrollLines As Long Public Mouse_Control As Control Public Mouse_Form As Form ' Windows API Declarations Public Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Public Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wp As Integer, ByVal lp As Long) As Long Public Declare Function GetSystemMetrics Lib "USER32" (ByVal nIndex As Long) As Long Public Declare Function SystemParametersInfo Lib "USER32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long Public Declare Function RegisterWindowMessage Lib "USER32" Alias "RegisterWindowMessageA" (ByVal LPString As String) As Long Public Sub Mouse_InitWheel(ByVal TheForm As Form, ByVal TheMsgHook As Msghook, Optional ByVal Loading As Boolean = False) On Error Resume Next Dim MSG_MOUSEWHEEL As Long Dim MSG_3DSUPPORT As Long Dim MSG_SCROLLLINES As Long Dim ReturnValue As Integer Dim hWheelForm As Long Dim Has3DSupport As Long Dim ScrollLinesNumber As Long '--------------------------------------------------------------------------- ' Win98, WinNT 4.0, and Win2000 - IntelliMouse is natively supported If GetSystemMetrics(SM_MOUSEWHEELPRESENT) Then If Loading = True Then ' Turn hook on TheMsgHook.HwndHook = TheForm.hWnd ' Check configuration If Loading = True Then TheMsgHook.Message(WM_SETTINGCHANGE) = True ' WM_SETTINGCHANGE = &H1A End If ' Check for mouse wheel scrolling TheMsgHook.Message(&H20A) = True End If ' Find out how many lines to scroll SystemParametersInfo 104, 0, ReturnValue, 0 ' Set lines to scroll to global variable Mouse_ScrollLines = ReturnValue '--------------------------------------------------------------------------- ' Win32s, Win95, and WinNT 3.5x - Intellimouse is not natively supported Else hWheelForm = FindWindow("MouseZ", "Magellan MSWHEEL") MSG_MOUSEWHEEL = RegisterWindowMessage("MSWHEEL_ROLLMSG") MSG_3DSUPPORT = RegisterWindowMessage("MSH_WHEELSUPPORT_MSG") MSG_SCROLLLINES = RegisterWindowMessage("MSH_SCROLL_LINES_MSG") If MSG_3DSUPPORT Then Has3DSupport = SendMessage(hWheelForm, MSG_3DSUPPORT, 0, 0) Else Has3DSupport = False End If ' Find out how many lines to scroll If MSG_SCROLLLINES <> 0 Then ScrollLinesNumber = SendMessage(hWheelForm, MSG_SCROLLLINES, 0, 0) Else ScrollLinesNumber = 3 ' Default End If ' Set lines to scroll to global variable Mouse_ScrollLines = ScrollLinesNumber If Loading = True Then If hWheelForm <> 0 Then ' IntelliMouse Found ' Turn hook on TheMsgHook.HwndHook = TheForm.hWnd ' Check configuration If Loading = True Then TheMsgHook.Message(WM_SETTINGCHANGE) = True ' WM_SETTINGCHANGE = &H1A End If ' Check for mouse wheel scrolling TheMsgHook.Message("&H" & Hex(MSG_MOUSEWHEEL)) = True End If End If End If End Sub ' 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. Public 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.hWnd = TheForm.hWnd 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 ' 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 '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