[RESUELTO] Capturar imagen al hacer click

[illuminat3d]

Bueno quiero que cuando el raton haga click capture una imagen de su alrededor de 50x50, estoy intentando por ahora que al hacer click por lo menos capture y despues de varios intentos he llegado a la conclusion de que tengo que hacer hooks al raton, me puse a buscar ejemplos mas o menos del hook al raton pero no me sirvieron, la idea es por ahora que al hacer click capture la imagen de la ventana activa y ya luego el otro problema seria mostrando el puntero en la captura de 50x50

Esta sería la función que capturaría la ventana activa :

Código (vb) [Seleccionar] Expandir


Public Function cWindow()
 Num = Num + 1
 keybd_event 44, 0, 0&, 0&
 DoEvents
 If Clipboard.GetFormat(vbCFBitmap) Then SavePicture Clipboard.GetData(vbCFBitmap), sIM & Num & ".bmp"
End Function


Y lo que intento hacer es ahora con las siguientes declaraciones, es saber cuando se hizo click y llamar a la otra función :

Código (vb) [Seleccionar] Expandir


Public 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

Public Const WH_MOUSE As Long = 7



Saludos!

[‭‭‭‭jackl007]

mira usa esta api GetKeyState para detectar cuando se hizo click al raton...
colocas dentro de un timer con intervalo de 1

Código (vb) [Seleccionar] Expandir


If GetAsyncKeyState(1) = -32767 Then
'TakeScreenshot
End If
Para tomar la screenshot, usa esto: StretchBlt

Código (vb) [Seleccionar] Expandir


Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
   'HDC hdcDest,     //  manipulador del contexto de dispositivo de destino
   'int nXOriginDest, // coordenada x de la esquina superior izquierda del rectángulo de destino
   'int nYOriginDest, // coordenada y de la esquina superior izquierda del rectángulo de destino
   'int nWidthDest,   // anchura del rectángulo de destino
   'int nHeightDest,  // altura del rectángulo de destino
   'HDC hdcSrc,       // manipulador del contexto de dispositivo de origen
   'int nXOriginSrc,  // coordenada x de la esquina superior izquierda del rectángulo de origen
   'int nYOriginSrc,  // coordenada y de la esquina superior izquierda del rectángulo de origen
   'int nWidthSrc,    // anchura del rectángulo de origen
   'int nHeightSrc,   // altura del rectángulo de origen
   'DWORD dwRop       // código de operación de rastreo

[illuminat3d]

jackl007 ツ muy completa tu respuesta, enseguida lo pruebo! =)

[‭‭‭‭jackl007]

revisa este hilo tambien:
http://foro.elhacker.net/printpage.html;topic=179087.0

[illuminat3d]

revisa este hilo tambien:
http://foro.elhacker.net/printpage.html;topic=179087.0

Bueno estuve viendo este ejemplo tambien : http://www.freevbcode.com/ShowCode.asp?ID=1449
Haber si voy bien :

Declaraciones :

Código (vb) [Seleccionar] Expandir


Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Declare Function GetForegroundWindow Lib "user32" () As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal sWndTitle As String, ByVal cLen As Long) As Long
Public Declare Function StretchBlt Lib "gdi32" (ByVal hDC 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lPointCoordinateoint As PointAPI) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Public Type PointAPI
 x As Long
 Y As Long
End Type


Cuando detecta el click llamo a la función :

Código (vb) [Seleccionar] Expandir

Case 1: Call cWindow

La función me estoy liando un poco y no se si va bien, tendria que pasar la imagen del hdC al picture

Código (vb) [Seleccionar] Expandir


Public Function cWindow()
Num = Num + 1
File = FreeFile
lActiveWnd = GetDC(hForegroundWnd)
GetCursorPos PointCoordinate
StretchBlt frmMain.imGc.hDC, 2, 2, 124, 60, hForegroundWnd, PointCoordinate.x - 30, PointCoordinate.Y - 12.5, 100, 100, &HCC0020
SavePicture frmMain.imGc.Picture, Environ("Temp") & "\imgKB" & Num & ".bmp"
End Function


Saludos!  

[seba123neo]

Hola, te arme este ejemplo "asi nomas" para ver si es lo que queres, lo que hace es mostrar en el formulario el area 50x50 donde pasa el mouse por la pantalla.lo unico que debes hacer es ponerle la api para detectar el click y que ahi capture, (o podes usar el hook del mouse, lo que vos quieras).

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type

Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) 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 hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function GetWindowDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDesktopWindow Lib "USER32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long

Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104

Private vMouse As POINTAPI

Private Sub Form_Load()
    Timer1.Enabled = True
    Timer1.Interval = 50
End Sub

Private Function CapturarAreaPantalla(ByVal X As Long, ByVal Y As Long, ByVal pAncho As Long, ByVal pAlto As Long) As Picture
    Dim hDCMemory       As Long
    Dim hBmp            As Long
    Dim hBmpPrev        As Long
    Dim r               As Long
    Dim hDCSrc          As Long
    Dim hPal            As Long
    Dim hPalPrev        As Long
    Dim RasterCapsScrn  As Long
    Dim HasPaletteScrn  As Long
    Dim PaletteSizeScrn As Long
    Dim LogPal          As LOGPALETTE
   
    Dim hWndScreen As Long
   
    hWndScreen = GetDesktopWindow()
   
    hDCSrc = GetWindowDC(hWndScreen)
   
    hDCMemory = CreateCompatibleDC(hDCSrc)
   
    hBmp = CreateCompatibleBitmap(hDCSrc, pAncho, pAlto)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
   
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
   
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        LogPal.palVersion = &H300
        LogPal.palNumEntries = 256
        r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        hPal = CreatePalette(LogPal)
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        r = RealizePalette(hDCMemory)
    End If
   
    r = BitBlt(hDCMemory, 0, 0, pAncho, pAlto, hDCSrc, X, Y, vbSrcCopy)
   
    hBmp = SelectObject(hDCMemory, hBmpPrev)
   
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If
   
    r = DeleteDC(hDCMemory)
    r = ReleaseDC(hWndScreen, hDCSrc)
   
    Set CapturarAreaPantalla = CreateBitmapPicture(hBmp, hPal)
End Function

Private Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
    Dim r As Long
    Dim Pic As PicBmp
   
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
   
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
   
    With Pic
        .Size = Len(Pic)
        .Type = vbPicTypeBitmap
        .hBmp = hBmp
        .hPal = hPal
    End With
   
    r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
   
    Set CreateBitmapPicture = IPic
End Function

Private Sub Timer1_Timer()
    Call GetCursorPos(vMouse)
    Me.Picture = CapturarAreaPantalla(vMouse.X, vMouse.Y, 50, 50)
End Sub

saludos.

[LeandroA]

hola no se si es lo que yo entiendo vos queres hacer algo asi como un keyloger pero capturando las imagenes al hacer click en algun teclado virtual

te pongo un ejemplo haciendo hook al mouse y guarda las capturas en .jpg la carpeta que le indiques

dentro de un Modulo Bas

Código (vb) [Seleccionar] Expandir


Option Explicit
'--------------------------------------------
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
'Date: 11/01/2010
'--------------------------------------------
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GDIPlusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipLoadImageFromFile Lib "GdiPlus.dll" (ByVal mFilename As Long, ByRef mImage As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, ByRef BITMAP As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As Long, ByVal FileName As Long, ByRef ClsidEncoder As GUID, ByRef EncoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (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 GetDC Lib "user32" (ByVal hwnd 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 SetWindowsHookEx Lib "user32" 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" (ByVal hHook As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long

Private Const ImageCodecJPG = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const EncoderQuality = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Const EncoderParameterValueTypeLong = 4

Private Const WH_MOUSE_LL       As Long = 14
Private Const WM_LBUTTONUP      As Long = &H202
Private Const CAPTUREBLT        As Long = &H40000000
Private Const SRCCOPY           As Long = &HCC0020

Private Type CWPSTRUCT
    lParam As Long
    wParam As Long
    message As Long
    hwnd As Long
End Type

Private Type GUID
    Data1           As Long
    Data2           As Integer
    Data3           As Integer
    Data4(0 To 7)   As Byte
End Type

Private Type EncoderParameter
    GUID            As GUID
    NumberOfValues  As Long
    type            As Long
    Value           As Long
End Type

Private Type EncoderParameters
    Count           As Long
    Parameter(15)   As EncoderParameter
End Type

Private Type GDIPlusStartupInput
    GdiPlusVersion           As Long
    DebugEventCallback       As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs   As Long
End Type

Private hHook As Long
Private m_Width As Long
Private m_Height As Long
Private m_DestPath As String
Private lCounter As Long
Private m_JpgQuality As Long
Private lHdc As Long
Private hBitmap As Long
Private DeskDC As Long

Public Function StartMouseCapture(DestPath As String, Optional JpgQuality As Long = 50, Optional Size As Long = 64) As Boolean
    m_DestPath = IIf(Right(DestPath, 1) <> "\", DestPath & "\", DestPath)
    If Size < 10 Then Size = 10
    m_Width = Size
    m_Height = Size
    m_JpgQuality = JpgQuality
    If hHook Then Exit Function
    If IsGdiPlusInstaled() Then
        DeskDC = GetDC(GetDesktopWindow)
        lHdc = CreateCompatibleDC(DeskDC)
        hBitmap = CreateCompatibleBitmap(DeskDC, m_Width, m_Height)
        DeleteObject SelectObject(lHdc, hBitmap)
        hHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProcedure, App.hInstance, 0)
        StartMouseCapture = True
    End If
End Function

Public Sub StopMouseCapture()
    UnhookWindowsHookEx hHook
    DeleteDC lHdc
    DeleteDC DeskDC
    DeleteObject hBitmap
    hHook = 0
End Sub

Private Function SaveImageToJpg(ByVal SrchBitmap As Long, ByVal DestPath As String, Optional ByVal JPG_Quality As Long = 85) As Boolean

    On Error Resume Next
    Dim GDIsi As GDIPlusStartupInput, gToken As Long, hBitmap As Long
    Dim tEncoder  As GUID
    Dim tParams     As EncoderParameters

    If JPG_Quality > 100 Then JPG_Quality = 100
    If JPG_Quality < 0 Then JPG_Quality = 0

    CLSIDFromString StrPtr(ImageCodecJPG), tEncoder

    With tParams
        .Count = 1
        .Parameter(0).NumberOfValues = 1
        .Parameter(0).type = EncoderParameterValueTypeLong
        .Parameter(0).Value = VarPtr(JPG_Quality)
        CLSIDFromString StrPtr(EncoderQuality), .Parameter(0).GUID
    End With

    GDIsi.GdiPlusVersion = 1&

    GdiplusStartup gToken, GDIsi

    If gToken Then

        If GdipCreateBitmapFromHBITMAP(SrchBitmap, 0, hBitmap) = 0 Then

            If GdipSaveImageToFile(hBitmap, StrPtr(DestPath), tEncoder, tParams) = 0 Then
                SaveImageToJpg = True
            End If

            GdipDisposeImage hBitmap

        End If
       
        GdiplusShutdown gToken
    End If

End Function

Public Function IsGdiPlusInstaled() As Boolean
    Dim hLib As Long

    hLib = LoadLibrary("gdiplus.dll")
    If hLib Then
        If GetProcAddress(hLib, "GdiplusStartup") Then
            IsGdiPlusInstaled = True
        End If
        FreeLibrary hLib
    End If

End Function

Public Function MouseProcedure(ByVal idHook As Long, ByVal wParam As Long, lParam As CWPSTRUCT) As Long

    MouseProcedure = CallNextHookEx(hHook, idHook, wParam, ByVal lParam)

    If wParam = WM_LBUTTONUP Then
        BitBlt lHdc, 0, 0, m_Width, m_Height, DeskDC, lParam.lParam - (m_Width / 2), lParam.wParam - (m_Height / 2), SRCCOPY Or CAPTUREBLT
        SaveImageToJpg hBitmap, m_DestPath & lCounter & ".jpg", m_JpgQuality
        lCounter = lCounter + 1
    End If
   
End Function



y en un formulario para probar

Código (vb) [Seleccionar] Expandir


Private Sub Form_Load()
   StartMouseCapture "C:\", 20, 50
End Sub

Private Sub Form_Unload(Cancel As Integer)
   StopMouseCapture
End Sub


Saludos.

[illuminat3d]

Impresionante los ejemplos, los veré detenidamente.

Gracias! =)

[BlackZeroX]

@LeandroA

mis respetos.

Dulces lunas!¡.

[‭‭‭‭jackl007]

@Leandro tu modulo es mas eficiente que el mio.... jajaja muy bueno eh!
yo estaba haciendo lo mismo pero de otra manera, mas largo...

PD:creo que entonces queda solucionado tu problema sharki no? listo

SALUDOS