Club Delphi  
    FTP   CCD     Buscar   Trucos   Trabajo   Foros

Retroceder   Foros Club Delphi > Otros temas > Trucos
Registrarse FAQ Miembros Calendario Guía de estilo Buscar Temas de Hoy Marcar Foros Como Leídos

Los mejores trucos

Respuesta
 
Herramientas Buscar en Tema Desplegado
  #1  
Antiguo 11-04-2014
FENIXadr FENIXadr is offline
Miembro
 
Registrado: may 2010
Ubicación: Córdoba - Cba. - Argentina
Posts: 98
Poder: 8
FENIXadr Va por buen camino
Keylogger con acentos y más..

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..

Última edición por FENIXadr fecha: 11-04-2014 a las 02:50:13.
Responder Con Cita
  #2  
Antiguo 11-04-2014
Avatar de ElKurgan
[ElKurgan] ElKurgan is offline
Miembro Premium
 
Registrado: nov 2005
Posts: 977
Poder: 12
ElKurgan Va por buen camino
Thumbs up

Gracias por el aporte
Responder Con Cita
  #3  
Antiguo 11-04-2014
Avatar de Neftali
Neftali Neftali is offline
-Germán Estévez-
 
Registrado: jul 2004
Ubicación: Barcelona - España
Posts: 15.255
Poder: 10
Neftali Va camino a la famaNeftali Va camino a la fama
Buen aporte.
Gracias.
__________________
Germán Estévez => Web/Blog
Guía de estilo, Guía alternativa
Utiliza TAG's en tus mensajes.
Contactar con el Clubdelphi

P.D: Más tiempo dedicado a la pregunta=Mejores respuestas.
Responder Con Cita
  #4  
Antiguo 11-04-2014
Avatar de Casimiro Notevi
Casimiro Notevi Casimiro Notevi is offline
Moderador
 
Registrado: sep 2004
Ubicación: En algún lugar.
Posts: 27.320
Poder: 10
Casimiro Notevi Tiene un aura espectacularCasimiro Notevi Tiene un aura espectacular
Responder Con Cita
  #5  
Antiguo 11-04-2014
Avatar de ecfisa
ecfisa ecfisa is offline
Moderador
 
Registrado: dic 2005
Ubicación: Tres Arroyos, Argentina
Posts: 9.738
Poder: 27
ecfisa is a splendid one to beholdecfisa is a splendid one to beholdecfisa is a splendid one to beholdecfisa is a splendid one to beholdecfisa is a splendid one to beholdecfisa is a splendid one to behold
Hola FENIXadr.

Lo mismo digo, interesante aporte

Saludos
__________________
Daniel Didriksen

Guía de estilo - Uso de las etiquetas - La otra guía de estilo ....
Responder Con Cita
  #6  
Antiguo 30-04-2015
Luciano_f Luciano_f is offline
Registrado
 
Registrado: abr 2015
Posts: 2
Poder: 0
Luciano_f Va por buen camino
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.
Responder Con Cita
  #7  
Antiguo 30-04-2015
Luciano_f Luciano_f is offline
Registrado
 
Registrado: abr 2015
Posts: 2
Poder: 0
Luciano_f Va por buen camino
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;
Responder Con Cita
Respuesta


Herramientas Buscar en Tema
Buscar en Tema:

Búsqueda Avanzada
Desplegado

Normas de Publicación
no Puedes crear nuevos temas
no Puedes responder a temas
no Puedes adjuntar archivos
no Puedes editar tus mensajes

El código vB está habilitado
Las caritas están habilitado
Código [IMG] está habilitado
Código HTML está deshabilitado
Saltar a Foro

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


La franja horaria es GMT +2. Ahora son las 13:52:44.


Powered by vBulletin® Version 3.6.8
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Traducción al castellano por el equipo de moderadores del Club Delphi
Copyright 1996-2007 Club Delphi