Mensajes

@░▒▓BlackZeroҖ▓▒░
esta bueno el ejemplo, te voy a tirar una sugerencia como ya me lo hicieron a mi en mi foro

al pasarle un lapiz a un hdc hay que eliminar el antiguo lapiz, esto es tanto como para un brocha, o un bitmap.

DeleteObject SelectObject(hdc, hPen)

y luego por ulitmo eliminas tu lapiz creado

DeleteObject hPen

a una cosa muy importate Compilalo!! sino es muy lento.

Saludos.

Hola para el efecto de vista si podrias usar SetLayeredWindowAttributes pero para el de apagado del xp te paso un metodo convirtiendo la pantalla a escala de grices.

Agrega a un formulario: Timer1, Picture1, Command1

Código (vb) [Seleccionar] Expandir

Option Explicit
'*-------------------------------------*
'Autor:     Leandro Ascierto
'web:       www.leandroascierto.com.ar
'Date:      13/01/2009
'Referncia  ApiGuide
'Requimientos Timer1, Picture1, Command1
'*-------------------------------------*
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage 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 Sub 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)

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 RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0

Private Const HWND_TOPMOST      As Long = -1
Private Const SWP_NOACTIVATE    As Long = &H10
Private Const SWP_SHOWWINDOW    As Long = &H40

Private bi24BitInfo     As BITMAPINFO
Private hBitmap         As Long
Private lHdc            As Long
Private bBytes()        As Byte
Dim lCunter             As Long

Private Sub Command1_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    Dim TempDC As Long
   
    Me.BorderStyle = 0
    Me.Caption = ""
    Me.WindowState = vbMaximized
    Me.AutoRedraw = True
    Command1.Caption = "Cancelar"
   
    TempDC = GetDC(0)
   
    With bi24BitInfo.bmiHeader
        .biBitCount = 24
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(bi24BitInfo.bmiHeader)
        .biWidth = Screen.Width / Screen.TwipsPerPixelX
        .biHeight = Screen.Height / Screen.TwipsPerPixelY
    End With
   
    ReDim bBytes(1 To bi24BitInfo.bmiHeader.biWidth * bi24BitInfo.bmiHeader.biHeight * 3) As Byte
   
    lHdc = CreateCompatibleDC(0)
    hBitmap = CreateDIBSection(lHdc, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
   
    SelectObject lHdc, hBitmap
   
    BitBlt lHdc, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, GetDC(0), 0, 0, vbSrcCopy
    GetDIBits lHdc, hBitmap, 0, bi24BitInfo.bmiHeader.biHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS
    BitBlt Me.hdc, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, TempDC, 0, 0, vbSrcCopy
   

   
    SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, SWP_NOACTIVATE Or SWP_SHOWWINDOW
   
    Picture1.Move (Me.ScaleWidth / 2) - (Picture1.ScaleWidth / 2), (Me.ScaleHeight / 2) - (Picture1.ScaleHeight / 2)
       
    lCunter = 0
    Timer1.Interval = 150
   
    DeleteDC TempDC
End Sub

Private Sub Form_Unload(Cancel As Integer)
    DeleteDC lHdc
    DeleteObject hBitmap
End Sub

Private Sub Timer1_Timer()
    Dim Cnt As Long, lGray As Long
    Dim lR As Long, lG As Long, lB As Long
   
    lCunter = lCunter + 1
   
    If lCunter > 60 < 65 Then
        For Cnt = LBound(bBytes) To UBound(bBytes) - 3 Step 3
            lB = bBytes(Cnt)
            lG = bBytes(Cnt + 1)
            lR = bBytes(Cnt + 2)
            lGray = (222 * lR + 707 * lG + 71 * lB) / 1000
            bBytes(Cnt) = (lB * 4 + lGray) / 5
            bBytes(Cnt + 1) = (lG * 4 + lGray) / 5
            bBytes(Cnt + 2) = (lR * 4 + lGray) / 5
        Next Cnt
       
        SetDIBitsToDevice Me.hdc, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, 0, 0, 0, _
            bi24BitInfo.bmiHeader.biHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS
           
        Me.Refresh
    End If
   
    If lCunter = 71 Then Timer1.Interval = 0
End Sub


Saludos.

Che Leandro, porque inicializas GDI+ cada vez que vas a guardar la imagen en vez de hacerlo en StartMouseCapture y terminarlo en StopMouseCapture? es para que no explote?

Exacto lo inicialize dentro de la funcion para que no crashe en el IDE pero bueno obiamente seria mejor ponerlo dentro de StartMouseCapture  o bien usar el GDIplusIDEsafe de LaVolpe pero bueno sale con fritas.

Leandro, mis respetos, está buenisimo el modulo. Pero sabes alguna forma de que en las capturas se vea el mouse? o se marque algún cuadrado?
Saludos!

podes poner estas dos apis

Código [Seleccionar] Expandir

Private Declare Function GetCursor Lib "user32" () As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long


y despues justo de la llamada al api BitBlt pones

Código [Seleccionar] Expandir

DrawIcon lHdc, (m_Width / 2), (m_Height / 2), GetCursor

pero te puede llegar a tapar la letra y no te serviria de nada la captura, mejor seria poner un puntito con SetPixel

Saludos.

mira este hilo
http://foro.elhacker.net/programacion_vb/duda_capturar_imagen_al_hacer_click-t280686.0.html;msg1383074#msg1383074

Saludos.

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.

Este es un modulo bas para Reiniciar la aplicación si es que aparece un error y no fue controlado  (No errores de sistemas esos que aparece el maldito boton"No Enviar") sino los comunes de vb

Código [Seleccionar] Expandir


Option Explicit
'Autor: Leandro Ascierto
'Web:   www.leandroascierto.com.ar
'Date:  28/12/2009
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function SetProp Lib "user32.dll" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Sub FatalExit Lib "kernel32" (ByVal code As Long)

Dim hWinStatic As Long
Dim AppPath As String
Dim LastError As Long

Private Function CallSomeFunction()
    'No borrar esta linea
End Function

Public Sub StarProtect()
    hWinStatic = CreateWindowEx(0, "Static", "WindowControlerCrash", 0, 0, 0, 0, 0, 0, 0, 0, 0&)
    AppPath = GetAppPath
    SetTimer hWinStatic, 0, 100, AddressOf TimerProc
End Sub

Public Sub EndProtect()
    KillTimer hWinStatic, 0
    DestroyWindow hWinStatic
End Sub

Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
    Dim Ret As String
   
    If Err.Number = 40040 Then
        ShellExecute hWinStatic, vbNullString, AppPath, LastError, vbNullString, 1
        FatalExit 1
    Else
        LastError = Err.Number
        Ret = CallSomeFunction
    End If
   
End Sub

Private Function GetAppPath() As String
    Dim ModuleName As String
    Dim Ret As Long
    ModuleName = String$(255, Chr$(0))
    Ret = GetModuleFileName(App.hInstance, ModuleName, 255)
    GetAppPath = Left$(ModuleName, Ret)
End Function


Para probarlo en un formulario con Tres botones

Código [Seleccionar] Expandir


Option Explicit

Private Sub Form_Load()
    If Command$ <> "" Then Me.Caption = "Aplicación Reinciada por error: " & Command$
    StarProtect 'comienza la protección
End Sub

Private Sub Form_Unload(Cancel As Integer)
    EndProtect 'Detiene la protección
End Sub


Private Sub Command1_Click()
    MsgBox 1 / 0 'Error Divición por cero
End Sub

Private Sub Command2_Click()
    Dim i As Integer
    i = 8000000000000# 'Error Desvordamiento
End Sub

Private Sub Command3_Click()
    Dim c As Date
    c = "hola" 'Error no coinciden los tipos
End Sub


Lo compilan y verán que al producir un error la aplicacion se reinicia.

Saludos.

hola mira este link creo que es lo que buscas

http://www.recursosvisualbasic.com.ar/htm/trucos-codigofuente-visual-basic/93.htm

Saludos.

podes usar apis como  GetDC, BitBlt, DrawText , pero bueno tenes que tener conosimiento de apis.

Saludos.

que es lo que no te funciona?.

SendMessage ret, WM_SYSCOMMAND, SC_CLOSE, ByVal 0

cierra la ventana pero no mata el proceso si la ventana no es la unica en ejecucion.

seguro que este es el nombre de clase ThunderRT6FormDC mira que si la aplicacion esta en ide es otro el classname.

Saludos.