' *************************************************************************
' Copyright ©2000 Karl E. Peterson, All Rights Reserved
' Find this and more samples at <[URL unfurl="true"]http://www.mvps.org/vb>[/URL]
' *************************************************************************
' You are free to use this code within your own applications, but you
' are expressly forbidden from selling or otherwise distributing this
' source code, non-compiled, without prior written consent.
' *************************************************************************
Option Explicit
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dX As Long, ByVal dY As Long, ByVal dwData As Long, ByVal dwExtraInfo As Long)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' API structure definition for Rectangle
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' Flags used with mouse_event
Private Const MOUSEEVENTF_ABSOLUTE = &H8000& ' absolute move
Private Const MOUSEEVENTF_LEFTDOWN = &H2 ' left button down
Private Const MOUSEEVENTF_LEFTUP = &H4 ' left button up
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20 ' middle button down
Private Const MOUSEEVENTF_MIDDLEUP = &H40 ' middle button up
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move
Private Const MOUSEEVENTF_RIGHTDOWN = &H8 ' right button down
Private Const MOUSEEVENTF_RIGHTUP = &H10 ' right button up
Private Const MOUSEEVENTF_WHEEL = &H800 ' wheel button rolled
' GetSystemMetrics() codes
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
' Value used to scale wheel movement
Private Const WHEEL_DELTA As Long = 120
' A few module level variables...
Private m_ScreenWidth As Long
Private m_ScreenHeight As Long
Private m_ClickDelay As Long
' Virtual scaling applied to screen...
Private Const m_Scale As Long = &HFFFF&
' Direction for wheel to turn...
Public Enum WheelDirections
meWheelForward = WHEEL_DELTA
meWheelBackward = -WHEEL_DELTA
End Enum
' ***********************************************************
' Initialize
' ***********************************************************
Private Sub Class_Initialize()
' Store screen dimensions in pixels
m_ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
m_ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
' Default duration for mousedown
m_ClickDelay = 250 'milliseconds
End Sub
' ***********************************************************
' Public Properties
' ***********************************************************
Public Property Let ClickDelay(ByVal NewVal As Long)
If NewVal >= 0 Then m_ClickDelay = NewVal
End Property
Public Property Get ClickDelay() As Long
ClickDelay = m_ClickDelay
End Property
' ***********************************************************
' Public Methods
' ***********************************************************
Public Sub ButtonPress(ByVal Button As MouseButtonConstants)
' Depress mouse button at current screen location.
Select Case Button
Case vbLeftButton, vbMiddleButton, vbRightButton
Call mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
Case vbMiddleButton
Call mouse_event(MOUSEEVENTF_MIDDLEDOWN, 0, 0, 0, 0)
Case vbRightButton
Call mouse_event(MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0)
End Select
End Sub
Public Sub ButtonRelease(ByVal Button As MouseButtonConstants)
' Release mouse button at current screen location.
Select Case Button
Case vbLeftButton, vbMiddleButton, vbRightButton
Call mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
Case vbMiddleButton
Call mouse_event(MOUSEEVENTF_MIDDLEUP, 0, 0, 0, 0)
Case vbRightButton
Call mouse_event(MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0)
End Select
End Sub
Public Sub Click()
' Click the mouse, with delay to simulate human timing.
Call mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
If m_ClickDelay Then
DoEvents ' allow down position to paint
Call Sleep(m_ClickDelay)
End If
Call mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
End Sub
' X/Y need to be passed as pixels!
Public Sub ClickAbsolute(ByVal X As Long, ByVal Y As Long)
' Move cursor to destination, first.
Call Me.MoveTo(X, Y)
' Click it
Call Me.Click
End Sub
Public Sub ClickWindow(ByVal hWnd As Long)
' Move cursor to window
Call Me.MoveToWindow(hWnd)
' Click it
Call Me.Click
End Sub
' X/Y need to be passed as pixels!
Public Sub MoveTo(ByVal X As Long, ByVal Y As Long, Optional ByVal Absolute As Boolean = True)
Dim meFlags As Long
If Absolute Then
' Map into same coordinate space used by mouse_event.
X = (X / m_ScreenWidth) * m_Scale
Y = (Y / m_ScreenHeight) * m_Scale
' Set flags
meFlags = MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE
Else
' Set flags for relative movement
meFlags = MOUSEEVENTF_MOVE
End If
' Move the cursor to destination.
Call mouse_event(meFlags, X, Y, 0, 0)
End Sub
Public Sub MoveToWindow(ByVal hWnd As Long)
Dim X As Long, Y As Long
Dim r As RECT
' Place origin in center of control.
If GetWindowRect(hWnd, r) <> 0 Then
X = r.Left + (r.Right - r.Left) \ 2
Y = r.Top + (r.Bottom - r.Top) \ 2
Call Me.MoveTo(X, Y)
Else
MsgBox ApiCalls.ApiErrorText(Err.LastDllError)
End If
End Sub
' Not supported in Windows95!
Public Sub TurnWheel(Optional ByVal Notches As Long = 1, Optional ByVal Direction As WheelDirections = meWheelBackward)
Dim dwData As Long
' Validate direction
If Direction <> meWheelBackward And Direction <> meWheelForward Then
Direction = meWheelBackward
End If
' Turn the wheel
dwData = Notches * Direction
Call mouse_event(MOUSEEVENTF_WHEEL, 0, 0, dwData, 0)
End Sub