Cursor auf Hex Farbe

[CrimeTime]

Hallo,
ich bin grade am Versuchen ein Programm zu erstellen, das wenn ich auf einen Button drücke der Cursor auf einen Hex Farben Code geht, und diesem gegebenenfalls Folgt, aber dies könnte man ja auch mit einem Timer machen..
Naja Gegoogelt habe ich schon, aber den Code den ich dort fand brachte mir nicht das gewünschte Ergebniss.

Bitte um Hilfe.

Gruß CrimeTime

 

[dr_pepper]

hey,

schau dir mal folgende apis an:


GetPixel
SetCursorPos

dazu wirst du noch die "GetDc" Api brauchen, um die(?) handle des desktops zu bekommen.

ich schätze einfach mal du möchtest sowas wie ein colorbot schreiben, nicht?

 

[CrimeTime]

Hier mal der Code den ich bissher habe:

Private Declare Function CreateDC Lib "GDI32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As String) As Integer
Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Integer) As Integer
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Integer, ByVal nIndex As Integer) As Integer
Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
Private Declare Function BitBlt Lib "GDI32" (ByVal srchDC As Integer, ByVal srcX As Integer, ByVal srcY As Integer, ByVal srcW As Integer, ByVal srcH As Integer, ByVal desthDC As Integer, ByVal destX As Integer, ByVal destY As Integer, ByVal op As Integer) As Integer
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Integer) As Integer
Private Declare Function DeleteObject Lib "GDI32" (ByVal hObj As Integer) As Integer
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Const SRCCOPY As Long = &HCC0020

Private Sub FindColor(ByVal MyColor As Integer)

-> Dim Spic As Picture1.Picture
Spic = CaptureScreen.GetScreen()
'capture the screen to a image

For i = 0 To Spic.Width - 1
For k = 0 To Spic.Height - 1
'itterate through each pixel
If ColorTranslator.ToOle(Spic.GetPixel(i, k)) = MyColor Then
'if the pixel is the same color we are looking for
SetCursorPos = i & k
'exit the routine to save time
Exit Sub 'maybe get rid of this line if you want to other pixels too

End If
Next
Next
End Sub

Public Function GetScreen()
Dim oBackground As String

Dim FW, FH As Integer
Dim hSDC, hMDC As Integer
Dim hBMP, hBMPOld As Integer
Dim r As Integer

hSDC = CreateDC("DISPLAY", "", "", "")
hMDC = CreateCompatibleDC(hSDC)

FW = GetDeviceCaps(hSDC, 8)
FH = GetDeviceCaps(hSDC, 10)

hBMP = CreateCompatibleBitmap(hSDC, FW, FH)

hBMPOld = SelectObject(hMDC, hBMP)
r = BitBlt(hMDC, 0, 0, FW, FH, hSDC, 0, 0, 0)
hBMP = SelectObject(hMDC, hBMPOld)

r = DeleteDC(hSDC)
r = DeleteDC(hMDC)

oBackground = Picture1.Picture(hBMP)
DeleteObject (hBMP)
End Function

Private Sub Command1_Click()
Dim SearchColor As Integer
SearchColor = vbBlack
FindColor (SearchColor)
End Sub

-> Zeigt den derzeitigen Fehler

 

[dr_pepper]

'-------------------
'Api: GetPixel
'-------------------
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, _
ByVal x As Long, ByVal y As Long) As Long
 
'---------------
'Api: GetDC
'---------------
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
 
'-------------------
'Api: SetCursorPos
'-------------------
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, _
ByVal y As Long) As Long

'----------------
'Api: Sleep
'----------------
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
 
 
Private Type POINTAPI
  x As Long
  y As Long
End Type
 
 
 
Dim CP As POINTAPI
 
'die n?chsten 3 funktionen sind NICHT von mir!
 
      Function GetRValue(ByVal nColor As Long) As Long
 
           GetRValue = nColor And &HFF&
 
      End Function
 
 
 
     Function GetGValue(ByVal nColor As Long) As Long
 
          GetGValue = (nColor \ &H100&) And &HFF&
          Debug.Print (GetGValue)
 
      End Function
 
 
       Function GetBValue(ByVal nColor As Long) As Long
 
          GetBValue = (nColor \ &H10000) And &HFF&
 
     End Function
 
 
 
'------------------------------
     'button: cmdGetPixel
'------------------------------
Private Sub cmdGetPixel_Click()
 
Dim y As Long, x As Long
Dim color As Long
 
 
 
    i = GetDC(DESKTOP_HWND) 'handle vom desktop
 
 
  Do
    For x = 300 To 1000  'berreich des pixel-scan vorgangs
    For y = 200 To 750
 
 
 
 
     color = GetPixel(i, x, y) 'farbe auslesen
 
     R = GetRValue(color)
     G = GetGValue(color)
     B = GetBValue(color)
 
 
       If R & G & B = 2080227 Then        'wenn farbe gefunden -> cursor auf die farbe bewegen
          Call SetCursorPos(x, y)
          Exit Sub
       End If
 
    Sleep (5)
 
     Next y
     Next x
 Loop
 
 
End Sub

etwas einfacher =)

 

[CrimeTime]

Der Code sieht echt Chic aus , aber wäre toll wenn diese auch gegen würde, also das der Cursor sich auf eine Farbe bewegt, das ich es etwas verstehen kann und mir so Umrüsten wie ich es brauche

Eigentlich sollte es mit Hex Farben Funktionieren, wenn ich diese übersehen hab bitte drauf anstoßen x)