Automatic mouse click operation
Code:
Option Explicit
Private Declare Function SystemParametersInfo _
Lib "user32" _
Alias "SystemParametersInfoA" (ByVal uAction As Long, _
ByVal uParam As Long, _
ByVal lpvParam As Long, _
ByVal fuWinIni As Long) As Long
Private Const SPI_SETSCREENSAVEACTIVE = 17
'Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal Scan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function MapVirtualKey _
Lib "user32" _
Alias "MapVirtualKeyA" (ByVal wCode As Long, _
ByVal wMapType As Long) As Long
'Const KEYEVENTF_KEYUP = &H2 '??????
'????????????
'Call keybd_event(13, MapVirtualKey("13", 0), 0, 0) '????
'Call keybd_event(13, MapVirtualKey("13", 0), KEYEVENTF_KEYUP, 0) '????
'Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Const VK_MENU = &H12 '??vbkeymenu
Private Const VK_CONTROL = &H11 'vbkeycontrol
Private Const VK_Shift = &H10 '????vbkeyshift
'Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
'Private Const KEYEVENTF_KEYUP = &H2
'Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_CHAR = &H102
Private Const WM_SETTEXT = &HC
Private Const VK_A = &H41
Private Const WM_SYSKEYDOWN = &H104
Private Const WM_SYSKEYUP = &H105
Private Const WM_SYSCHAR = &H106
Private Const EM_GETSEL = &HB0
Private Const EM_SETSEL = &HB1
'Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_COPY = &H301
Private Const WM_PASTE = &H302
Private Const WM_CUT = &H300
Private Const WM_COPYDATA = &H4A
Private Const WM_SETFOCUS As Long = &H7&
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'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 Declare Function GetMessageExtraInfo Lib "user32" () As Long
'Private Const MOUSEEVENTF_MOVE = &H1
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Private Declare Function SetCursorPos _
Lib "user32" (ByVal X As Long, _
ByVal Y As Long) As Long '??????????
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 MOUSEEVENTF_ABSOLUTE = &H8000& 'win10???????'???????????????????????????????65535×65535???
Private Const MOUSEEVENTF_MOVE = &H1 '????
Private Const MOUSEEVENTF_LEFTDOWN = &H2 '????????
Private Const MOUSEEVENTF_LEFTUP = &H4 '????????
Private Const MOUSEEVENTF_RIGHTDOWN = &H8 '????????
Private Const MOUSEEVENTF_RIGHTUP = &H10 '????????
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20 '????????
Private Const MOUSEEVENTF_MIDDLEUP = &H40 '????????
'????
'????API
Const KEYEVENTF_KEYUP = &H2
'Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
Private Declare Sub keybd_event _
Lib "user32.dll" (ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long)
Private Declare Function PostMessageW _
Lib "user32.dll" (ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Const WM_CLEAR = &H303
Private Declare Function SendMessage _
Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
'????API
Private Declare Function PostMessage _
Lib "user32" _
Alias "PostMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function MessageBoxTimeout _
Lib "user32" _
Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long, _
ByVal wlange As Long, _
ByVal dwTimeout As Long) As Long
Private Const WM_LBUTTONDOWN = &H201
Private Const MK_LBUTTON = &H1
Private Const WM_LBUTTONUP = &H202
'==========================================
'Private Const MOUSEEVENTF_LEFTDOWN = &H2 ' left button down
'Private Const MOUSEEVENTF_LEFTUP = &H4 ' left button up
'Private Const MOUSEEVENTF_MOVE = &H1
'Private Const MOUSEEVENTF_ABSOLUTE = &H8000&
Private Const SM_CXSCREEN = 0 'X Size of screen
Private Const SM_CYSCREEN = 1 'Y Size of Screen
'Private Type POINTAPI
' x As Long
' y As Long
'End Type
'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 Declare Function GetMessageExtraInfo Lib "user32" () As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
'Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen _
Lib "user32" (ByVal hwnd As Long, _
lpPoint As POINTAPI) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Private Sub ClickLabel(nLabelName As String, Optional Index As Integer = -1)
' Dim iCtl As Control
' Dim iLbl As Label
' Dim iM As POINTAPI
' Dim iLblPos As POINTAPI
' Get the Label
' For Each iCtl In Me.Controls
' If iCtl.Name = nLabelName Then
' If Index > -1 Then
' If iCtl.Index = Index Then
' Set iLbl = iCtl
' End If
' Else
' Set iLbl = iCtl
' End If
' End If
' Next
' Click on the Label
' If Not iLbl Is Nothing Then
' iLblPos.x = Me.ScaleX(iLbl.Left + iLbl.width / 2, Me.ScaleMode, vbPixels)
' iLblPos.y = Me.ScaleY(iLbl.Top + iLbl.height / 2, Me.ScaleMode, vbPixels)
'
' ClientToScreen Me.hwnd, iLblPos
' GetCursorPos iM
'
' mouse_event MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE, iLblPos.x * (&HFFFF& / GetSystemMetrics(SM_CXSCREEN)), iLblPos.y * (&HFFFF& / GetSystemMetrics(SM_CYSCREEN)), 0, GetMessageExtraInfo()
' mouse_event MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP, 0&, 0&, 0&, GetMessageExtraInfo()
' mouse_event MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE, iM.x * (&HFFFF& / GetSystemMetrics(SM_CXSCREEN)), iM.y * (&HFFFF& / GetSystemMetrics(SM_CYSCREEN)), 0, GetMessageExtraInfo()
'
' End If
'End Sub
'??????
'https://www.vbforums.com/showthread.php?888665-RESOLVED-Mouse-move-API-problem&highlight=MOUSEEVENTF_MOVE
Public Sub MakeMouseMove()
'??????
Dim iCP As POINTAPI
Dim iPixelXInMouseCoord As Double
Dim iPixelYInMouseCoord As Double
GetCursorPos iCP
' iPixelXInMouseCoord =&HFFFF& / GetSystemMetrics(SM_CXSCREEN)
iPixelXInMouseCoord = 65535 / (Screen.Width \ Screen.TwipsPerPixelX)
iPixelYInMouseCoord = 65535 / (Screen.Height \ Screen.TwipsPerPixelY)
iCP.X = iCP.X * iPixelXInMouseCoord
iCP.Y = iCP.Y * iPixelYInMouseCoord
mouse_event MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE, iCP.X + iPixelXInMouseCoord, iCP.Y + iPixelYInMouseCoord, 0&, GetMessageExtraInfo()
DoEvents
mouse_event MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE, iCP.X, iCP.Y, 0&, GetMessageExtraInfo()
End Sub
'???????
'???x?x????????
'???y?y????????
Public Sub ScreenMove(ByVal X As Long, ByVal Y As Long)
Dim iPixelXInMouseCoord As Double
Dim iPixelYInMouseCoord As Double
Dim mw As Long, mh As Long
iPixelXInMouseCoord = 65535 / (Screen.Width \ Screen.TwipsPerPixelX)
iPixelYInMouseCoord = 65535 / (Screen.Height \ Screen.TwipsPerPixelY)
mw = X * iPixelXInMouseCoord
mh = Y * iPixelYInMouseCoord
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, mw, mh, 0&, GetMessageExtraInfo()
'mouse_event MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub
'???????
'???x?x????????
'???y?y????????
'???f???????
Public Sub formMove(ByVal X As Long, ByVal Y As Long, f As Form)
f.SetFocus '//????
ScreenMove f.Left / Screen.TwipsPerPixelX + X, f.Top / Screen.TwipsPerPixelX + Y
End Sub
'???????
'???x?x????????
'???y?y????????
Public Sub ScreenClick(ByVal X As Long, ByVal Y As Long)
' mw = X / (Screen.width / 15) * 65535
' mh = Y / (Screen.height / 15) * 65535
Dim iPixelXInMouseCoord As Double
Dim iPixelYInMouseCoord As Double
Dim mw As Long, mh As Long
iPixelXInMouseCoord = 65535 / (Screen.Width \ Screen.TwipsPerPixelX)
iPixelYInMouseCoord = 65535 / (Screen.Height \ Screen.TwipsPerPixelY)
mw = X * iPixelXInMouseCoord
mh = Y * iPixelYInMouseCoord
SetCursorPos X, Y
'mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, mw, mh, 0&, GetMessageExtraInfo()
mouse_event MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP, 0, 0, 0&, GetMessageExtraInfo()
End Sub
Public Sub ScreenLeftClick(ByVal X As Long, ByVal Y As Long)
' mw = X / (Screen.width / 15) * 65535
' mh = Y / (Screen.height / 15) * 65535
Dim iPixelXInMouseCoord As Double
Dim iPixelYInMouseCoord As Double
Dim mw As Long, mh As Long
iPixelXInMouseCoord = 65535 / (Screen.Width \ Screen.TwipsPerPixelX)
iPixelYInMouseCoord = 65535 / (Screen.Height \ Screen.TwipsPerPixelY)
mw = X * iPixelXInMouseCoord
mh = Y * iPixelYInMouseCoord
SetCursorPos X, Y
'mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, mw, mh, 0&, GetMessageExtraInfo()
mouse_event MOUSEEVENTF_LEFTDOWN, 0&, 0&, 0&, GetMessageExtraInfo()
Sleep 80
mouse_event MOUSEEVENTF_LEFTUP, 0&, 0&, 0&, GetMessageExtraInfo()
End Sub
Public Sub ScreenRightClick(ByVal X As Long, ByVal Y As Long)
' mw = X / (Screen.width / 15) * 65535
' mh = Y / (Screen.height / 15) * 65535
Dim iPixelXInMouseCoord As Double
Dim iPixelYInMouseCoord As Double
Dim mw As Long, mh As Long
iPixelXInMouseCoord = 65535 / (Screen.Width \ Screen.TwipsPerPixelX)
iPixelYInMouseCoord = 65535 / (Screen.Height \ Screen.TwipsPerPixelY)
mw = X * iPixelXInMouseCoord
mh = Y * iPixelYInMouseCoord
'SetCursorPos X, Y
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, mw, mh, 0&, GetMessageExtraInfo()
mouse_event MOUSEEVENTF_RIGHTDOWN, 0&, 0&, 0&, GetMessageExtraInfo()
Sleep 50
mouse_event MOUSEEVENTF_RIGHTUP, 0&, 0&, 0&, GetMessageExtraInfo()
End Sub
'???vb????
'???x?x????????
'???y?y????????
'???f???????
Public Sub formClick(ByVal X As Long, ByVal Y As Long, f As Form)
f.SetFocus '//????
ScreenClick f.Left / Screen.TwipsPerPixelX + X, f.Top / Screen.TwipsPerPixelX + Y
End Sub
'//????
Public Sub clickTimes(clickMsg, f As Form, Optional isScreenClick As Boolean = False)
Dim t, X, Y, arr, a
If InStr(clickMsg, "|") = 0 Then clickMsg = clickMsg & "|" '//????????????????
arr = Split(clickMsg, "|")
For a = 0 To UBound(arr)
If InStr(arr(a), "x:") > 0 And InStr(arr(a), "y:") > 0 Then
t = zq(arr(a), "t:", ";")
X = zq(arr(a), "x:", ";")
Y = zq(arr(a), "y:", ";")
'//????
If isScreenClick = False Then
cls_delay Val(t) '//??
formClick Val(X), Val(Y), f '//????
'//????
Else
cls_delay Val(t) '//??
ScreenClick Val(X), Val(Y) '//????
End If
End If
Next a
End Sub
Public Sub cls_delay(HowLong As Date)
'////hex ????
Dim TempTime
TempTime = DateAdd("s", HowLong, Now)
While TempTime > Now
DoEvents '? windows ??????
Wend
End Sub
Private Function zq(allStr, sta, fin) As String
'////hex '????
Dim arr
Dim i, c
arr = Split(allStr, sta)
For i = 1 To UBound(arr)
If InStr(arr(i), fin) Then c = Split(arr(i), fin)(0)
Next i
zq = c
End Function