VBCoding Библиотека кодов Visual Basic 6 Оболочка и система Курсор: Перемещение, центрирование, имитация нажатия

Visual Basic 6
Курсор: Перемещение, центрирование, имитация нажатия

В данном примеры вы можете: CenterMouseOn - центрировать курсор мыши на каком-либо элементе, MouseMove - передвигать мышь в определенную точку экрана, MouseFullClick - имитировать нажатие клавиш мыши.

Private Const MOUSEEVENTF_ABSOLUTE = &H8000
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20
Private Const MOUSEEVENTF_MIDDLEUP = &H40
Private Const MOUSEEVENTF_MOVE = &H1
Private Const MOUSEEVENTF_RIGHTDOWN = &H8
Private Const MOUSEEVENTF_RIGHTUP = &H10

Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cbuttons As Long, ByVal dwExtraInfo As Long)

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const TWIPS_PER_INCH = 1440
Private Const POINTS_PER_INCH = 72

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Private Const MOUSE_MICKEYS = 65535

Public Enum enReportStyle
rsPixels
rsTwips
rsInches
rsPoints
End Enum

Public Enum enButtonToClick
btcLeft
btcRight
btcMiddle
End Enum

' Returns the screen size in pixels or, optionally, in others scalemode styles
Public Sub GetScreenRes(ByRef X As Long, ByRef Y As Long, Optional ByVal ReportStyle As enReportStyle)
X = GetSystemMetrics(SM_CXSCREEN)
Y = GetSystemMetrics(SM_CYSCREEN)
If Not IsMissing(ReportStyle) Then
If ReportStyle <> rsPixels Then
X = X * Screen.TwipsPerPixelX
Y = Y * Screen.TwipsPerPixelY
If ReportStyle = rsInches Or ReportStyle = rsPoints Then
X = X \ TWIPS_PER_INCH
Y = Y \ TWIPS_PER_INCH
If ReportStyle = rsPoints Then
X = X * POINTS_PER_INCH
Y = Y * POINTS_PER_INCH
End If
End If
End If
End If
End Sub

' Convert's the mouses coordinate system to a pixel position.
Public Function MickeyXToPixel(ByVal mouseX As Long) As Long
Dim X As Long
Dim Y As Long
Dim tX As Single
Dim tmouseX As Single
Dim tMickeys As Single
GetScreenRes X, Y
tX = X
tMickeys = MOUSE_MICKEYS
tmouseX = mouseX
MickeyXToPixel = CLng(tmouseX / (tMickeys / tX))
End Function

' Converts mouse Y coordinates to pixels
Public Function MickeyYToPixel(ByVal mouseY As Long) As Long
Dim X As Long
Dim Y As Long
Dim tY As Single
Dim tmouseY As Single
Dim tMickeys As Single
GetScreenRes X, Y
tY = Y
tMickeys = MOUSE_MICKEYS
tmouseY = mouseY
MickeyYToPixel = CLng(tmouseY / (tMickeys / tY))
End Function

' Converts pixel X coordinates to mickeys
Public Function PixelXToMickey(ByVal pixX As Long) As Long
Dim X As Long
Dim Y As Long
Dim tX As Single
Dim tpixX As Single
Dim tMickeys As Single
GetScreenRes X, Y
tMickeys = MOUSE_MICKEYS
tX = X
tpixX = pixX
PixelXToMickey = CLng((tMickeys / tX) * tpixX)
End Function

' Converts pixel Y coordinates to mickeys
Public Function PixelYToMickey(ByVal pixY As Long) As Long
Dim X As Long
Dim Y As Long
Dim tY As Single
Dim tpixY As Single
Dim tMickeys As Single
GetScreenRes X, Y
tMickeys = MOUSE_MICKEYS
tY = Y
tpixY = pixY
PixelYToMickey = CLng((tMickeys / tY) * tpixY)
End Function

Public Function CenterMouseOn(ByVal hwnd As Long) As Boolean
Dim X As Long
Dim Y As Long
Dim maxX As Long
Dim maxY As Long
Dim crect As RECT
Dim rc As Long
GetScreenRes maxX, maxY
rc = GetWindowRect(hwnd, crect)
If rc Then
X = crect.Left + ((crect.Right - crect.Left) / 2)
Y = crect.Top + ((crect.Bottom - crect.Top) / 2)
If (X >= 0 And X <= maxX) And (Y >= 0 And Y <= maxY) Then
MouseMove X, Y
CenterMouseOn = True
Else
CenterMouseOn = False
End If
Else
CenterMouseOn = False
End If
End Function

Public Function MouseFullClick(ByVal MBClick As enButtonToClick) As Boolean
Dim cbuttons As Long
Dim dwExtraInfo As Long
Dim mevent As Long
Select Case MBClick
Case btcLeft
mevent = MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP
Case btcRight
mevent = MOUSEEVENTF_RIGHTDOWN Or MOUSEEVENTF_RIGHTUP
Case btcMiddle
mevent = MOUSEEVENTF_MIDDLEDOWN Or MOUSEEVENTF_MIDDLEUP
Case Else
MouseFullClick = False
Exit Function
End Select
mouse_event mevent, 0&, 0&, cbuttons, dwExtraInfo
MouseFullClick = True
End Function

Public Sub MouseMove(ByRef xPixel As Long, ByRef yPixel As Long)
Dim cbuttons As Long
Dim dwExtraInfo As Long
mouse_event MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE, PixelXToMickey(xPixel), PixelYToMickey(yPixel), cbuttons, dwExtraInfo
End Sub

Private Sub Command1_Click()
Call CenterMouseOn(Command1.hwnd)
End Sub

 

Иcточник: http://www.vbnet.ru/
 

Добавить комментарий


Защитный код
Обновить

 
VBCoding Библиотека кодов Visual Basic 6 Оболочка и система Курсор: Перемещение, центрирование, имитация нажатия  
Powered by Exponenta -