Píxeles y Bucle For

[raul338]

No entiendo el porqué lo ideal sería colocar el cursor luego de encontrar el pixel que se busca, pero pues sabes lo que haces.

Eso, importa el puntero del mouse? GetDC y ReleaseDC consumen IO

[ignorantev1.1]

P.D: Te importaría darme tu msn?

Si es para mí, mandame tu msn por PM, si no lo es... emmm... el caballo corre por el campo...

Eso, importa el puntero del mouse? GetDC y ReleaseDC consumen IO

Exacto, ¿por qué no colocarlos fuera del bucle?

¿Y de mi plantiamiento ni hablamos verdad? 

Saludos!

[raul338]

¿Y de mi plantiamiento ni hablamos verdad? 

Para eso es la misma tecnica, no podemos usar el DC como un mapa de bits asi que hay que convertirlo a BMP de ahi trabajar libremente

[calk9]

Jaj no me había fijado en eso, ya lo saqué del bucle pero el problema no era eso sino la sentencia if y el ver el color del pixel actual en donde se encuentra el mouse. Yo pense en ponerlo en un timer el código para verificar el color del pixel pero el bucle for es mucho más rapido que 1 milisegundo (que es el menor intervalo de un timer). Pues entonces digo, hago un hook y que al detectar WM_MOUSEMOVE verifique el color del pixel así estaría a la misma velocidad que el bulce... supongo jej. Pero necesito hacer un hook al mouse, no a mi aplicación y de otra ni hablar ya que tendría que inyectar una DLL... y no en basic  .

Alguna idea? 

Saludos.

[raul338]

Para hacer un hook al mouse no tienes que inyectar una DLL, solo necesitas una funcion en un modulo

[calk9]

Sep pero para un proceso que no es el mio si necesito inyectar una DLL. Como podría hookear el mouse, sin especificar un determinado hwnd, simplemente los mensajes del mouse?

Saludos

[Hasseds]

mmm... revisá si esto  puede servir, en caso q sirva... te toca optimizar.

Código (vb) [Seleccionar] Expandir



Option Explicit

Private Sub Form_Load()
 Call SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, &H2 Or &H1)
 AutoRedraw = True
 FontBold = True
 BackColor = &HAA431B
 ForeColor = vbWhite
 StartHook
End Sub

Private Sub Form_Unload(Cancel As Integer)
 StopHook
End Sub



Código (vb) [Seleccionar] Expandir



Option Explicit

Private Declare Function SetWindowsHookEx Lib "user32.dll" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Const WH_MOUSE_LL As Long = 14

Private Type POINTAPI: x As Long: y As Long: End Type

Dim hHook As Long
Dim lDC As Long

Public Sub StartHook()
   hHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, App.hInstance, &H0&)
   lDC = GetWindowDC(&H0&)
End Sub


Public Sub StopHook()
   Call UnhookWindowsHookEx(hHook)
   hHook = &H0&
   Call ReleaseDC(&H0&, lDC)
End Sub


Private Function MouseProc(ByVal ncode As Long, ByVal wParam As Long, lParam As POINTAPI) As Long
   
   Dim lColor As Long
   lColor = GetPixel(lDC, lParam.x, lParam.y)
   
   'If Not lColor < 0 Then
     'Form1.Cls
     'Form1.Print Hex(lColor)
     If lColor = &HAA431B Then
       Form1.Caption = "SI"
     Else
       Form1.Caption = "NO"
     End If
   'End If
 
 MouseProc = CallNextHookEx(hHook, ncode, wParam, lParam)

End Function





[raul338]

Creo que estas equivocando en conceptos

Para hacer un Hook al mouse no necesitas un hwnd especifico, es directo al mouse, pase por donde pase, haga lo que haga

Lo que tu quieres caputrar son los mensajes del mouse sobre una ventana, se llama "subclassing". Esta la clase de Paul Caton para subclassifcar formularios de tus proyectos, pero cuando se trata de otras aplicaciones, solo queda una dll que se injecta sola (anda dando vueltas por ahi )

Revisa bien que quieres hacer, para mi que con solo hookear el mouse alcanza

[LeandroA]

Hola, si es masomenos lo que entiendo esta es la forma mas rapida

Código (vb) [Seleccionar] Expandir


Option Explicit
'Autor: Leandro Ascierto
'Web: http://leandroascierto.com/blog/
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
Private Declare Function SetCursorPos Lib "user32.dll" (ByVal x As Long, ByVal y As Long) As Long

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type

Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Const DIB_RGB_COLORS = 0
Private Const BI_RGB = 0&


Private Function FindColorInScreen(ByVal oColor As OLE_COLOR, ByRef PT() As POINTAPI) As Long
    Dim ScreenDC As Long
    Dim TmpDC As Long
    Dim hBmp As Long
    Dim OldBmp As Long
    Dim Addrs As Long
    Dim x As Long
    Dim y As Long
    Dim lpBits() As Long
    Dim BI As BITMAPINFO
    Dim SA As SAFEARRAY2D
    Dim W As Long, H As Long
    Dim lColor As Long
   
    W = Screen.Width / Screen.TwipsPerPixelX
    H = Screen.Height / Screen.TwipsPerPixelY

    With BI.bmiHeader
        .biSize = Len(BI.bmiHeader)
        .biWidth = W
        .biHeight = H
        .biPlanes = 1
        .biBitCount = 32
        .biCompression = BI_RGB
        .biSizeImage = AlignScan(.biWidth, .biBitCount) * .biHeight
    End With

    ScreenDC = GetDC(0)
    TmpDC = CreateCompatibleDC(ScreenDC)
    hBmp = CreateDIBSection(ScreenDC, BI, DIB_RGB_COLORS, Addrs, 0, 0)

    OldBmp = SelectObject(TmpDC, hBmp)

    Call BitBlt(TmpDC, 0, 0, W, H, ScreenDC, 0, 0, vbSrcCopy)
   
    Call ReleaseDC(0&, ScreenDC)

    With SA
        .cbElements = 4
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = H
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = (BI.bmiHeader.biSizeImage \ .Bounds(0).cElements) \ 4
        .pvData = Addrs
    End With

    CopyMemory ByVal VarPtrArray(lpBits), VarPtr(SA), 4

    ReDim PT(0)
   
    lColor = ConvertColor(oColor)

    For y = H - 1 To 0 Step -1
        For x = 0 To W - 1
            If lpBits(x, y) = lColor Then
                ReDim Preserve PT(FindColorInScreen)
                With PT(FindColorInScreen)
                    .x = x
                    .y = H - y
                End With
                FindColorInScreen = FindColorInScreen + 1
            End If
        Next
    Next

    CopyMemory ByVal VarPtrArray(lpBits), 0&, 4
    Call DeleteObject(SelectObject(TmpDC, OldBmp))
    Call DeleteDC(TmpDC)
End Function

Private Function AlignScan(ByVal inWidth As Long, ByVal inDepth As Integer) As Long
    AlignScan = (((inWidth * inDepth) + &H1F) And Not &H1F&) \ &H8
End Function

Private Function ConvertColor(oColor As OLE_COLOR) As Long
    Dim RGBA(0 To 3) As Byte
    Dim BGRA(0 To 3) As Byte
    OleTranslateColor oColor, 0, VarPtr(RGBA(0))
    BGRA(0) = RGBA(2)
    BGRA(1) = RGBA(1)
    BGRA(2) = RGBA(0)
    BGRA(3) = &HFF
    CopyMemory ConvertColor, BGRA(0), 4&
End Function

Private Sub Form_Load()
    Dim lCount As Long
    Dim PT() As POINTAPI
    Me.AutoRedraw = True
    lCount = FindColorInScreen(vbBlue, PT)
    If lCount > 0 Then
        SetCursorPos PT(0).x, PT(0).y
        Dim i As Long
        For i = 0 To lCount - 1
            Debug.Print PT(i).x, PT(i).y
        Next
    End If
End Sub


[calk9]

mmm... revisá si esto  puede servir, en caso q sirva... te toca optimizar.

Código (vb) [Seleccionar] Expandir



Option Explicit

Private Sub Form_Load()
 Call SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, &H2 Or &H1)
 AutoRedraw = True
 FontBold = True
 BackColor = &HAA431B
 ForeColor = vbWhite
 StartHook
End Sub

Private Sub Form_Unload(Cancel As Integer)
 StopHook
End Sub



Código (vb) [Seleccionar] Expandir



Option Explicit

Private Declare Function SetWindowsHookEx Lib "user32.dll" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Const WH_MOUSE_LL As Long = 14

Private Type POINTAPI: x As Long: y As Long: End Type

Dim hHook As Long
Dim lDC As Long

Public Sub StartHook()
   hHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, App.hInstance, &H0&)
   lDC = GetWindowDC(&H0&)
End Sub


Public Sub StopHook()
   Call UnhookWindowsHookEx(hHook)
   hHook = &H0&
   Call ReleaseDC(&H0&, lDC)
End Sub


Private Function MouseProc(ByVal ncode As Long, ByVal wParam As Long, lParam As POINTAPI) As Long
   
   Dim lColor As Long
   lColor = GetPixel(lDC, lParam.x, lParam.y)
   
   'If Not lColor < 0 Then
     'Form1.Cls
     'Form1.Print Hex(lColor)
     If lColor = &HAA431B Then
       Form1.Caption = "SI"
     Else
       Form1.Caption = "NO"
     End If
   'End If
 
 MouseProc = CallNextHookEx(hHook, ncode, wParam, lParam)

End Function





Excelente justo lo que necesitaba! Gracias.