[FENIXadr]

Hola gente.. hace unos días necesité hacer un hook de teclado para capturar la combinación de unas teclas, busque en distintos lugares y lo que resultó al final del día fue un keylogger pero después de un corto tiempo de usarlo vi que tenía ciertos inconvenientes, como por ejemplo las letras con acento, no solo que el hook me capturaba la letra sin el acento sino que lo más grave es que se "comía" el acento de la aplicación en que yo estuviera.. otro inconveniente fueron los códigos ASCII que ponemos con el tecladito numérico y ALT presionado.. en mi caso el teclado que tengo es muy bonito pero no tiene los signos mayor y menor lo cual para poner "distinto" en delphi (ej. : a <> b) es toda una odisea con ALT+60 y ALT+62 pero el hook, otra vez, no solo que me capturaba un "60" o un "62", según el caso, sino que también me los "comía" en las aplicaciones, así que se complicaba usar delphi con el hook activado, o intentar poner los acentos con el tecladito numérico, además cuando presionaba SHIFT o ALTGR para poner algún caracter especial, tardaba una tecla en responder y cuando soltaba el SHIFT o el ALTGR tardaba otra tecla en desactivarse o sea si por ejemplo escribía "11111$$$$$66666" esto es, 5 veces "1" luego presionamos SHIFT, luego 5 veces "4", soltamos SHIFT y 5 veces "6" lo que en realidad capturaba era "111114$$$$&6666" como ven se tardaba una tecla en responder y cuando soltaba se tardaba una tecla en desactivarse.. esto no afectaba ninguna aplicación pero entorpecía la captura..
Estos inconveniente los vi en todos los ejemplos con hook que encontré y después de renegar un tiempo pude solucionarlos casi todos.. lo único que resta es capturar el codigo ASCII presionando ALT, no lo veo muy complicado pero creo que no merece la pena hacerlo.. lo bueno de esto es que las aplicaciones funcionan correctamente sin que el Hook entorpezca... (pude salvar mis tan "amados" ALT+60 y ALT+62 mientras funciona el Hook.)

Bien.. vamos al código

Nada es 100% infalible seguramente hay algunas combinaciones de teclas que se escapan.. pero funciona bastante bien..

Código Delphi [-]

library Hook;

uses
  Messages,
  Windows;

{$R *.RES}


const
      mapName: PChar = 'k9i:f$d8aR1';
      KeyMsg: Integer = WM_USER+1627;
      MseMsg: Integer = WM_USER+1628;

var
  hKeyHook, hMseHook, hMemFile: THandle;
  Hooked: Boolean = False;
  pFHandle: PHandle = nil;
  Acento1, Acento2, Dieresis, Angulo, ShiftDWN, AltDWN, AltGrDWN : Boolean;
  KeyState1: TKeyBoardState;
  

procedure CloseMap;
begin
  if pFHandle = nil then Exit;
  UnmapViewOfFile(pFHandle);
  CloseHandle(hMemFile);
  pFHandle := nil;
end;




function KeyHookFunc(Code, VirtualKey, KeyStroke: Integer): LRESULT; stdcall;
var
    AryChar: Array[0..1] of Char;
    Count : Integer;
begin
  // I had trouble with NON-syncronus key values in separate thread message queues
  // so I used the GetKeyboardState function
  Result := 0;
  if Code = HC_NOREMOVE then Exit;
  Result := CallNextHookEx(hKeyHook, Code, VirtualKey, KeyStroke);

  if (Code < 0) or (Code <> HC_ACTION) or IsBadCodePtr(pFHandle) then Exit;

  GetKeyboardState(KeyState1);

  case (KeyStroke shr 16) of
    42, 54              : ShiftDWN := True;
    49194, 49206        : ShiftDWN := False;
    8248, 12344         : AltDWN   := True;
    49208               : AltDWN   := False;
  end;

  if AltDWN then exit;     // Aqui liberamos a las Aplicaciones del Hook para no perder los códigos ASCII del teclado Numérico.
  
  if GetKeyState(VK_LMENU) = 1 then
    AltGrDWN := True;

  if ((KeyStroke and (1 shl 30)) <> 0) then
  begin
    if ShiftDWN then
      KeyState1[VK_SHIFT] := 128     // Simulamos SHIFT presionado para que no demore una tecla en activarse
    else
      KeyState1[VK_SHIFT] := 0;       // Simulamos SHIFT soltado para que no demore una tecla en desactivarse

    if AltGrDWN then
      KeyState1[VK_LMENU] := 128     // Simulamos ALTGR presionado para que no demore una tecla en activarse
    else
      KeyState1[VK_LMENU] := 0;       // Simulamos ALTGR soltado para que no demore una tecla en desactivarse


    if not AltDWN then
      KeyState1[VK_RMENU] := 0;
    

    Count := ToAscii(VirtualKey,KeyStroke, KeyState1, AryChar, 0);
    ToAscii(VirtualKey,KeyStroke, KeyState1, AryChar, 0);              // esto es para que las aplicaciones no pierdan los acentos. (Raro no?)
    case Count of
      1 :
        begin
          if Acento1 then
          begin
            Acento1 := false;
            case AryChar[0] of
              ' ' : AryChar[0] := '´';
              'a' : AryChar[0] := 'á';
              'e' : AryChar[0] := 'é';
              'i' : AryChar[0] := 'í';
              'o' : AryChar[0] := 'ó';
              'u' : AryChar[0] := 'ú';

              'A' : AryChar[0] := 'Á';
              'E' : AryChar[0] := 'É';
              'I' : AryChar[0] := 'Í';
              'O' : AryChar[0] := 'Ó';
              'U' : AryChar[0] := 'Ú';
            end;
          end;

          if Acento2 then
          begin
            Acento2 := false;
            case AryChar[0] of
              ' ' : AryChar[0] := '`';
              'a' : AryChar[0] := 'à';
              'e' : AryChar[0] := 'è';
              'i' : AryChar[0] := 'ì';
              'o' : AryChar[0] := 'ò';
              'u' : AryChar[0] := 'ù';

              'A' : AryChar[0] := 'À';
              'E' : AryChar[0] := 'È';
              'I' : AryChar[0] := 'Ì';
              'O' : AryChar[0] := 'Ò';
              'U' : AryChar[0] := 'Ù';
            end;
          end;

          if Dieresis then
          begin
            Dieresis := False;
            case AryChar[0] of
              ' ' : AryChar[0] := '¨';
              'a' : AryChar[0] := 'ä';
              'e' : AryChar[0] := 'ë';
              'i' : AryChar[0] := 'ï';
              'o' : AryChar[0] := 'ö';
              'u' : AryChar[0] := 'ü';

              'A' : AryChar[0] := 'Ä';
              'E' : AryChar[0] := 'Ë';
              'I' : AryChar[0] := 'Ï';
              'O' : AryChar[0] := 'Ö';
              'U' : AryChar[0] := 'Ü';
            end;
          end;

          if Angulo then
          begin
            Angulo := false;
            case AryChar[0] of
              ' ' : AryChar[0] := '^';
              'a' : AryChar[0] := 'â';
              'e' : AryChar[0] := 'ê';
              'i' : AryChar[0] := 'ê';
              'o' : AryChar[0] := 'î';
              'u' : AryChar[0] := 'ô';

              'A' : AryChar[0] := 'Â';
              'E' : AryChar[0] := 'Ê';
              'I' : AryChar[0] := 'Î';
              'O' : AryChar[0] := 'Ô';
              'U' : AryChar[0] := 'Û';
            end;

          end;          
          PostMessage(pFHandle^, KeyMsg, Ord(AryChar[0]), KeyStroke);
        end;
      2 :
        begin
          case AryChar[0] of
            '´' : Acento1 := true;
            '`' : Acento2 := true;
            '¨' : Dieresis := true;
            '^' : Angulo := true;  // no se como se llama entonces le puse Angulo.. si tiene otro nombre me avisan.. 
          end;
        end;
    end;
  end;
end;




function MseHookFunc(Code, mMsg: Integer; var MouseRec: TMOUSEHOOKSTRUCT): Integer; stdcall;
var
    Pos: Integer;
    reVal: SmallInt;
begin
  // to get the message information into 2 Integer values (wParam, lParam), I use the HiWord and LoWord
  Result := 0;
  if Code = HC_NOREMOVE then Exit;
  Result := CallNextHookEx(0, Code, mMsg, Integer(@MouseRec));
  if (Code < 0) or (Code <> HC_ACTION) or IsBadCodePtr(pFHandle) then Exit;

  reVal := MouseRec.pt.x;
  Pos := Word(reVal);
  reVal := MouseRec.pt.y;
  Pos := Pos or (Word(reVal) shl 16); // 2 SmallInt values in the LParam
  mMsg := mMsg or (Integer(MouseRec.dwExtraInfo) shl 16);// 2 Word values in the WParam
  PostMessage(pFHandle^, MseMsg, mMsg, Pos);
end;



// you must include the Forms window Handle in the StartHook
// StartHook is succesfull if it returns Zero
function StartHook(FormHandle: THandle): Integer; export;
begin
  Result := 1;
  if Hooked then Exit;

  if not IsWindow(FormHandle) then
  begin
    Result := 2;
    Exit;
  end;

  hMemFile := CreateFileMapping($FFFFFFFF, // $FFFFFFFF gets a page memory file
  nil, // no security attributes
  PAGE_READWRITE, // read/write access
  0, // size: high 32-bits
  SizeOf(THandle), // size: low 32-bits
  mapName); // name of map object
  pFHandle := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0);
  if pFHandle = nil then
  begin
    CloseHandle(hMemFile);
    Result := 3;
    Exit;
  end;

  hKeyHook := SetWindowsHookEx(WH_KEYBOARD, @KeyHookFunc, hInstance, 0);
  if hKeyHook = 0 then
  begin
    CloseMap;
    Result := 6;
    Exit;
  end;

  hMseHook := SetWindowsHookEx(WH_MOUSE, @MseHookFunc, hInstance, 0);
  if hMseHook = 0 then
  begin
    CloseMap;
    UnhookWindowsHookEx(hKeyHook);
    Result := 5;
    Exit;
  end;

  Acento1 := False;
  Acento2 := False;
  Dieresis := False;
  Angulo := False;
  Hooked := True;
  pFHandle^ := FormHandle;
  Result := 0;
end;


function StopHook: Boolean; export; // success if true
begin
  if Hooked then
  begin
    Result := UnhookWindowsHookEx(hKeyHook) and UnhookWindowsHookEx(hMseHook);
  end else
    Result := True;

  if Result then
  begin
    CloseMap;
    hKeyHook := 0;
    hMseHook := 0;
    Hooked := False;
  end;
end;



procedure EntryProc(Reason: Cardinal);
begin
  if (Reason = Dll_Process_Detach) then
  begin
    CloseMap;
    if Hooked then
    begin
      UnhookWindowsHookEx(hMseHook);
      UnhookWindowsHookEx(hKeyHook);
    end;
  end;
end;


exports
StartHook, StopHook;


begin
  DLLProc := @EntryProc;
  hMemFile := OpenFileMapping(FILE_MAP_WRITE, False, mapName);
  if hMemFile <> 0 then
    pFHandle := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0);
end.

y la implementación sería algo asi..

Código Delphi [-]

.....
......
....

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    .......
    .....
    procedure FormCreate(Sender: TObject);    
    procedure FormDestroy(Sender: TObject);    
    .....
  private
    { Private declarations }
    hLibGI: THandle;
    procedure HookMsgKey(var Msg1: TMessage); message WM_USER+1627;
    procedure HookMsgMse(var Msg1: TMessage); message WM_USER+1628;
  public
    { Public declarations }
  end;


var
  Form1: TForm1;
  StopHook : Procedure;
  ......
  ....
  ......

implementation

{$R *.dfm}


// aquí guardamos las teclas presionadas en un TMemo.
procedure TForm1.HookMsgKey(var Msg1: TMessage);
begin
    Memo1.Perform(WM_CHAR, Msg1.wParam, 0);
end;



// tratamos los eventos del Mouse aquí.
procedure TForm1.HookMsgMse(var Msg1: TMessage);
var
  Str1: String;
begin
  {below are most of the mouse messages
  WM_LBUTTONDBLCLK
  WM_LBUTTONDOWN
  WM_LBUTTONUP
  WM_MBUTTONDBLCLK
  WM_MBUTTONDOWN
  WM_MBUTTONUP
  WM_MOUSEACTIVATE
  WM_MOUSEMOVE
  WM_MOUSEWHEEL
  WM_NCLBUTTONDBLCLK
  WM_NCLBUTTONDOWN
  WM_NCLBUTTONUP
  WM_NCMBUTTONDBLCLK
  WM_NCMBUTTONDOWN
  WM_NCMBUTTONUP
  WM_NCMOUSEMOVE
  WM_NCRBUTTONDBLCLK
  WM_NCRBUTTONDOWN
  WM_NCRBUTTONUP
  WM_RBUTTONDBLCLK
  WM_RBUTTONDOWN
  WM_RBUTTONUP }

  // because WM_MOUSEWHEEL is different I have it first
  if Msg1.wParamLo = WM_MOUSEWHEEL then
  begin
    Str1 := 'mouseWheel - '+IntToStr(SmallInt(Msg1.wParamHi));
    //' at x:'+IntToStr(SmallInt(Msg1.LParamLo))+
    // ' y:'+IntToStr(SmallInt(Msg1.LParamHi));
    Memo1.Lines.Add(Str1);
    Exit;                                    
  end
  else
    case Msg1.wParamLo of
      WM_LBUTTONDOWN: Str1 := 'Left Button Down';
      WM_LBUTTONUP: Str1 := 'WM_LBUTTONUP';
      WM_MBUTTONDOWN: Str1 := 'WM_MBUTTONDOWN';
      WM_MBUTTONUP: Str1 := 'WM_MBUTTONUP';
      WM_MOUSEMOVE: Str1 := 'WM_MOUSEMOVE';
      WM_NCLBUTTONDOWN: Str1 := 'WM_NCLBUTTONDOWN';
      WM_RBUTTONDOWN: Str1 := 'WM_RBUTTONDOWN';
      WM_RBUTTONUP: Str1 := 'WM_RBUTTONDOWN';
    else
      Exit; // Warning, I just exit here to avoid all of the WM_MOUSEMOVE messages in memo
  end;

  Str1 := 'mouse - '+Str1+' at x:'+IntToStr(SmallInt(Msg1.LParamLo))+
  ' y:'+IntToStr(SmallInt(Msg1.LParamHi));

  //Memo1.Lines.Add(Str1);  

end;



procedure TForm1.FormCreate(Sender: TObject);
var
    StartHook: function(FormHandle: THandle): Integer;
    Re: Integer;
    MsgStr: String;
begin
  MsgStr := 'FAILED to Load Library';
  hLibGI := LoadLibrary('Hook.dll');
  if hLibGI > 0 then
  begin

    @StopHook := GetProcAddress(hLibGI,'StopHook');

    @StartHook := GetProcAddress(hLibGI,'StartHook');
    if @StartHook <> nil then
    begin
      Re := StartHook(Handle);
      if Re = 0 then
        MsgStr := 'Success - Hooks Are Running'
      else
        MsgStr := 'ERROR - Hooks NOT Started, Error code is '+IntToStr(Re);
    end
    else
    begin
      FreeLibrary(hLibGI);
      MsgStr := 'ERROR - StartHook function NOT in Library';
    end;
  end;


  ShowMessage(MsgStr);
end;



procedure TForm1.FormDestroy(Sender: TObject);
begin
  StopHook;
end;

y eso es todo...
he dejado algunos comentarios en ingles que son del autor original.. como dije buscando por todos lados encontré cosas y las junté.. espero que les sea de utilidad y si tienen algún inconveniente, comentario o alguna forma mas "elegante" de hacer lagunas de las cosas que hice serán muy bien aceptadas..

Saludos..