home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / CodeBrowse1967031222006.psc / CMouseEvent.cls < prev    next >
Text File  |  2005-05-29  |  5KB  |  153 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "CMouseEvent"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. ' *************************************************************************
  15. '  Copyright ⌐2000 Karl E. Peterson, All Rights Reserved
  16. '  Find this and more samples at <http://www.mvps.org/vb>
  17. ' *************************************************************************
  18. '  You are free to use this code within your own applications, but you
  19. '  are expressly forbidden from selling or otherwise distributing this
  20. '  source code, non-compiled, without prior written consent.
  21. ' *************************************************************************
  22. Option Explicit
  23.  
  24. Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
  25. Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  26. 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)
  27. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  28. Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
  29. Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
  30.  
  31. ' API structure definition for Rectangle
  32. Private Type RECT
  33.     Left As Long
  34.     Top As Long
  35.     Right As Long
  36.     Bottom As Long
  37. End Type
  38.  
  39. ' API structure definition for Mouse Coordinates
  40. Private Type POINTAPI
  41.     X As Long
  42.     Y As Long
  43. End Type
  44.  
  45. ' Flags used with mouse_event
  46. Private Const MOUSEEVENTF_ABSOLUTE = &H8000& ' absolute move
  47. Private Const MOUSEEVENTF_LEFTDOWN = &H2     ' left button down
  48. Private Const MOUSEEVENTF_LEFTUP = &H4       ' left button up
  49. ' middle button up
  50. Private Const MOUSEEVENTF_MOVE = &H1         ' mouse move
  51. ' right button up
  52.  
  53. ' GetSystemMetrics() codes
  54. Private Const SM_CXSCREEN = 0
  55. Private Const SM_CYSCREEN = 1
  56.  
  57. ' A few module level variables...
  58. Private m_ScreenWidth As Long
  59. Private m_ScreenHeight As Long
  60. Private m_ClickDelay As Long
  61.  
  62. ' Virtual scaling applied to screen...
  63. Private Const m_Scale As Long = &HFFFF&
  64.  
  65.  
  66. Public Sub SetMousePos(xPos As Long, yPos As Long)
  67.  
  68.  
  69. 100 SetCursorPos xPos, yPos
  70. End Sub
  71. Public Function GetY() As Long
  72.  
  73.  
  74.     Dim n As POINTAPI
  75. 100 GetCursorPos n
  76. 102 GetY = n.Y
  77. End Function
  78. Public Function GetX() As Long
  79.  
  80.  
  81.     Dim n As POINTAPI
  82. 100 GetCursorPos n
  83. 102 GetX = n.X
  84. End Function
  85. ' ***********************************************************
  86. '  Initialize
  87. ' ***********************************************************
  88. Private Sub Class_Initialize()
  89.  
  90.     ' Store screen dimensions in pixels
  91. 100 m_ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
  92. 102 m_ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
  93.     ' Default duration for mousedown
  94. 104 m_ClickDelay = 0   '250 'milliseconds
  95. End Sub
  96.  
  97.  
  98.  
  99. Public Sub Click()
  100.  
  101.     ' Click the mouse, with delay to simulate human timing.
  102. 100 Call mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
  103. 102 If m_ClickDelay Then
  104. 104     DoEvents ' allow down position to paint
  105. 106     Call Sleep(m_ClickDelay)
  106.     End If
  107. 108 Call mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
  108. End Sub
  109.  
  110. Public Sub ClickWindow(ByVal hWnd As Long)
  111.  
  112.     ' Move cursor to window
  113. 100 Call Me.MoveToWindow(hWnd)
  114.     ' Click it
  115. 102 Call Me.Click
  116. End Sub
  117.  
  118. ' X/Y need to be passed as pixels!
  119. Public Sub MoveTo(ByVal X As Long, ByVal Y As Long, Optional ByVal Absolute As Boolean = True)
  120.  
  121.     Dim meFlags As Long
  122.  
  123. 100 If Absolute Then
  124.         ' Map into same coordinate space used by mouse_event.
  125. 102     X = (X / m_ScreenWidth) * m_Scale
  126. 104     Y = (Y / m_ScreenHeight) * m_Scale
  127.         ' Set flags
  128. 106     meFlags = MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE
  129.     Else
  130.         ' Set flags for relative movement
  131. 108     meFlags = MOUSEEVENTF_MOVE
  132.     End If
  133.  
  134.     ' Move the cursor to destination.
  135. 110 Call mouse_event(meFlags, X, Y, 0, 0)
  136. End Sub
  137.  
  138. Public Sub MoveToWindow(ByVal hWnd As Long)
  139.  
  140.     Dim X As Long, Y As Long
  141.     Dim r As RECT
  142.  
  143.     ' Place origin in center of control.
  144. 100 Call GetWindowRect(hWnd, r)
  145. 102 X = r.Left + (r.Right - r.Left) \ 2
  146. 104 Y = r.Top + (r.Bottom - r.Top) \ 2
  147. 106 Call Me.MoveTo(X, Y)
  148. End Sub
  149.  
  150.  
  151.  
  152.  
  153.