Perfetto ora funziona! però è sorto un'altro problema.. MOOOLTO STRANO...
quando premo i pulsanti il mouse va dove vuole lui... ed è come se ci fosse un riquadro nelmonitor invisibile.. dove premendo queste frecce va sempre li... il riquadro è in alto a sinistra dello schermo....
non so se mi spiego... comunque il codice è questo
codice:
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Const KEYEVENTF_EXTENDEDKEY = &H1 'indica la pressione del tasto (keyDown)
Private Const KEYEVENTF_KEYUP = &H2 'indica il rilascio del tasto premuto (keyUp)
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y 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 Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
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_MOVE = &H1 ' mouse move
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20
Private Const MOUSEEVENTF_MIDDLEUP = &H40
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 Declare Function GetMessageExtraInfo Lib "user32" () As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Const SM_CXSCREEN = 0 'X Size of screen
Const SM_CYSCREEN = 1 'Y Size of Screen
Private Sub ScreenToAbsolute(lpPoint As POINTAPI)
lpPoint.x = lpPoint.x * (&HFFFF& / GetSystemMetrics(SM_CXSCREEN))
lpPoint.y = lpPoint.y * (&HFFFF& / GetSystemMetrics(SM_CYSCREEN))
End Sub
Sub Pause(HowLong As Long)
On Error Resume Next
Dim u%, tick As Long
tick = GetTickCount()
Do
u% = DoEvents
Loop Until tick + HowLong < GetTickCount
End Sub
Private Sub MoveCursor(p As POINTAPI)
'p.X and p.Y in absolute coordinates
'Put the mouse on the point
mouse_event MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE, p.x, p.y, 0, GetMessageExtraInfo()
End Sub
Private Sub Timer1_Timer()
Dim p As POINTAPI
Dim Posizione As POINTAPI
Dim PuntoX As Integer
Dim PuntoY As Integer
GetCursorPos Posizione
'per ricavare la posizione x e y
p.x = Posizione.x 'coordinata del punto x
p.y = Posizione.y 'coordinata del punto y
If GetAsyncKeyState(vbKeyRight) Then
Posizione.x = p.x + 2
Posizione.y = p.y
SetCursorPos p.x, p.y 'sposta il cursore del mouse al centro dello schermo
p.x = p.x + 3 'coordinata X
p.y = p.y 'coordinata Y
ScreenToAbsolute p 'converte il punto da coordinate dello schermo a coordinate "assolute" (espresse in 65536esimi di lunghezza/altezza dello schermo)
MoveCursor p 'muove
'Pause 50
End If
If GetAsyncKeyState(vbKeyLeft) Then
p.x = p.x - 1 'coordinata X
p.y = p.y 'coordinata Y
ScreenToAbsolute p 'converte il punto da coordinate dello schermo a coordinate "assolute" (espresse in 65536esimi di lunghezza/altezza dello schermo)
MoveCursor p 'muove
'Pause 50
'Pause 50
End If
End Sub
Private Sub Timer2_Timer()
Dim Handle As Long, Ret As Long
Handle = FindWindow(vbNullString, lblcaption.Caption)
Dim Posizione As POINTAPI
Dim p As POINTAPI
Dim PuntoX As Integer
Dim PuntoY As Integer
GetCursorPos Posizione
'per ricavare la posizione x e y
p.x = Posizione.x 'coordinata del punto x
p.y = Posizione.y 'coordinata del punto y
If GetAsyncKeyState(vbKeyUp) Then
'Posizione.x = PuntoX
'Posizione.y = PuntoY - 2
' Posizione.x = PuntoX '\ Screen.TwipsPerPixelX 'metà larghezza della finestra in pixel
' Posizione.y = PuntoY - 2 '\ Screen.TwipsPerPixelY 'metà altezza della finestra in pixel
' ClientToScreen Handle, Posizione 'finestra od oggetto di riferimento per la funzione SetCursorPos
' SetCursorPos Posizione.x, Posizione.y 'sposta il cursore del mouse al centro della finestra
'MsgBox p.x
p.x = p.x 'coordinata X
p.y = p.y - 1 'coordinata Y
ScreenToAbsolute p 'converte il punto da coordinate dello schermo a coordinate "assolute" (espresse in 65536esimi di lunghezza/altezza dello schermo)
MoveCursor p 'muove
'Pause 50
End If
If GetAsyncKeyState(vbKeyDown) Then
p.x = p.x 'coordinata X
p.y = p.y + 1 'coordinata Y
ScreenToAbsolute p 'converte il punto da coordinate dello schermo a coordinate "assolute" (espresse in 65536esimi di lunghezza/altezza dello schermo)
MoveCursor p 'muove
'Pause 50
'Posizione.x = PuntoX
' Posizione.y = PuntoY + 2
' SetCursorPos Posizione.x, Posizione.y 'sposta il cursore del mouse al centro dello schermo
End If
End Sub
Private Sub Timer3_Timer()
Dim foreground_hwnd As Long
Dim txt As String
Dim length As Long
foreground_hwnd = GetForegroundWindow()
txt = Space$(1024)
length = GetWindowText(foreground_hwnd, txt, Len(txt))
txt = Left$(txt, length)
lblcaption = txt
End Sub
Provatelo anche voi e ditemi se vi da lo stesso problema... non è il gioco che da problemi è proprio questo codice credo.. perchè me lo fa anche senza gioco aperto....
Mi date una mano? :S:S
Permessi di invio
Rispondi quotando