Ganchos globales de teclado y raton

[jocaro]

Hola

A partir de distintos códigos vistos en internet he preparado una DLL y un form de delphi para capturar eventos de teclado y ratón de otras aplicaciones
He conseguido recoger información de eventos de teclado y, en algun momento, también de ratón, pero he debido cambiar algo y ahora sólo recibo los eventos de teclado

Si alguien me puede ayudar a continuación va el código de la Dll y del form

Código Delphi [-]

{DLL}

library Ganchos;

uses
  Windows, Messages, StrUtils, SysUtils, Math;

const
  MENSAJE_TECLA = WM_USER + $1000;
  MENSAJE_RATON = WM_USER + $2000;

var
  GanchoDeTeclado: HHook;
  GanchoDeRaton: HHook;
  FichMem: THandle;
  PReceptor: ^Integer;

function IntToBin(valor,digitos:integer):string;
 var
  resultado:string;
  i:integer;
 begin
  if digitos>32 then
   digitos:=32;
  Resultado:='';
  i:=0;
  while i< digitos do
  begin
   if ((1 shl i) AND valor)>0 then
    Resultado:='1'+resultado
   else
    Resultado:='0'+resultado;
   inc(i);
  end;
  Result:=resultado;
 end;

{Esta es la funcion CallBack a la cual llamará el Gancho de teclado.}
function CallBackDelGanchoDeTeclado( Code: Integer;
                          wParam  : WPARAM;
                          lParam  : LPARAM
                          )       : LRESULT; stdcall;

begin

  { Si se ha producido una acción de pulsación de tecla }
  if (code=HC_ACTION) and
     (((lParam shr 31) and 1)<>1) and
     (((lParam shr 30) and 1)<>1) then
  begin

    {Miramos si existe el fichero de memoria}
    FichMem:=OpenFileMapping(FILE_MAP_READ,False,'Intercambio');
    {Si no existe, no enviamos nada a la aplicacion receptora}
    if FichMem > 0 then
    begin

      { Pasar como wParam del sendmessage el manejador de ventana activa y habrá
        que mantener el wParam original para enviarlo tal cual al CallNextHookEx }

      { Cargar objeto de datos de la pulsación para enviar mensaje }
      PReceptor:=MapViewOfFile(FichMem,FILE_MAP_READ,0,0,0);
      PostMessage(PReceptor^, MENSAJE_TECLA, GetforegroundWindow, lParam);
      UnmapViewOfFile(PReceptor);
      CloseHandle(FichMem);
    end;
  end;

  {Llamamos al siguiente Gancho de teclado de la cadena}
  Result := CallNextHookEx(GanchoDeTeclado, Code, wParam, lParam);

end;

{Esta es la funcion CallBack a la cual llamará el Gancho de ratón.}
function CallBackDelGanchoDeRaton( Code: Integer;
                          wParam  : WPARAM;
                          lParam  : LPARAM
                          )       : LRESULT; stdcall;

begin
  OutputDebugString( pwidechar(Code) );
  OutputDebugString( pwidechar(wparam) );
  OutputDebugString( pwidechar(lParam) );

  { Si se ha producido una acción y es click izquierdo ratón }
  if (code=HC_ACTION) then
  begin
    OutputDebugString( 'hc_action' );

    {Miramos si existe el fichero de memoria}
    FichMem:=OpenFileMapping(FILE_MAP_READ,False,'Intercambio');
    {Si no existe, no enviamos nada a la aplicacion receptora}
    if FichMem > 0 then
    begin

      { ?? }

      OutputDebugString( 'fichmem' );

      { Cargar objeto de datos de la pulsación para enviar mensaje }
      PReceptor:=MapViewOfFile(FichMem,FILE_MAP_READ,0,0,0);
      PostMessage(PReceptor^, MENSAJE_RATON, wParam, lParam);
      UnmapViewOfFile(PReceptor);
      CloseHandle(FichMem);
    end;
  end;

  {Llamamos al siguiente Gancho de ratón de la cadena}
  Result := CallNextHookEx(GanchoDeRaton, Code, wParam, lParam);

end;

{Procedure que instala el Gancho de teclado}
procedure GanchoDeTecladoOn; stdcall;
begin
  GanchoDeTeclado:=SetWindowsHookEx(WH_KEYBOARD, @CallBackDelGanchoDeTeclado, HInstance, 0);
end;

{procedure para desinstalar el Gancho de teclado}
procedure GanchoDeTecladoOff;  stdcall;
begin
  UnhookWindowsHookEx(GanchoDeTeclado);
end;

{Procedure que instala el Gancho de ratón}
procedure GanchoDeRatonOn; stdcall;
begin
  GanchoDeRaton:=SetWindowsHookEx(WH_MOUSE, @CallBackDelGanchoDeRaton, HInstance, 0);
end;

{procedure para desinstalar el Gancho de ratón}
procedure GanchoDeRatonOff;  stdcall;
begin
  UnhookWindowsHookEx(GanchoDeRaton);
end;

exports
{Exportamos las procedures...}
GanchoDeTecladoOn,
GanchoDeTecladoOff,
GanchoDeRatonOn,
GanchoDeRatonOff;

begin
end.

Código Delphi [-]

{PAS}

unit SimPul;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Vcl.ComCtrls;

const
  NombreDLL = 'Ganchos.dll';
  MENSAJE_TECLA = WM_USER + $1000;
  MENSAJE_RATON = WM_USER + $2000;

type
  TGanchoTeclado=procedure; stdcall;
  TGanchoRaton=procedure; stdcall;

type
  TVent = class(TForm)
    LiPuVi: TListView;
    procedure CrearForm(Sender: TObject);
    procedure DestruirForm(Sender: TObject);
  private
    { Private declarations }
    FichMem: THandle;
    PuntRecept: ^Integer;
    ManejDLL: THandle;
    GanchoDeTecladoOn, GanchoDeTecladoOff: TGanchoTeclado;
    GanchoDeRatonOn, GanchoDeRatonOff: TGanchoRaton;

    procedure LlegaDelGanchoDeTeclado(var message: TMessage); message  MENSAJE_TECLA;
    procedure LlegaDelGanchoDeRaton(var message: TMessage); message  MENSAJE_RATON;

  public
    { Public declarations }

  end;

var
  Vent: TVent;
  LisIte: TListItem;

implementation

{$R *.DFM}

procedure TVent.CrearForm(Sender: TObject);
begin

  ManejDLL:=LoadLibrary( PChar(ExtractFilePath(Application.Exename)+
                                NombreDLL ) );
  if ManejDLL = 0 then raise Exception.Create('No se pudo cargar la DLL');

  @GanchoDeTecladoOn :=GetProcAddress(ManejDLL, 'GanchoDeTecladoOn');
  @GanchoDeTecladoOff:=GetProcAddress(ManejDLL, 'GanchoDeTecladoOff');

  @GanchoDeRatonOn :=GetProcAddress(ManejDLL, 'GanchoDeRatonOn');
  @GanchoDeRatonOff:=GetProcAddress(ManejDLL, 'GanchoDeRatonOff');

  IF not assigned(GanchoDeTecladoOn) or
     not assigned(GanchoDeTecladoOff) or
     not assigned(GanchoDeRatonOn) or
     not assigned(GanchoDeRatonOff)  then
     raise Exception.Create('No se encontraron las funciones en la DLL'+#13+
                            'Cannot find the required DLL functions');

  {Creamos el fichero de memoria}
  FichMem:=CreateFileMapping( $FFFFFFFF,
                              nil,
                              PAGE_READWRITE,
                              0,
                              SizeOf(Integer),
                              'Intercambio');

   {Si no se crea el fichero, error}
   if FichMem=0 then
     raise Exception.Create( 'Error al crear el fichero'+
                             '/Error while create file');

   {Direccionamos nuestra estructura al fichero de memoria}
   PuntRecept:=MapViewOfFile(FichMem,FILE_MAP_WRITE,0,0,0);

   {Escribimos datos en el fichero de memoria}
   PuntRecept^ := Handle;
   GanchoDeTecladoOn;
   GanchoDeRatonOn;
end;

procedure TVent.DestruirForm(Sender: TObject);
begin
{Desactivamos el Hook}
{Uninstall the Hook}
if Assigned(GanchoDeTecladoOff) then GanchoDeTecladoOff;
if Assigned(GanchoDeRatonOff) then GanchoDeRatonOff;

{Liberamos la DLL}
{Free the DLL}
if ManejDLL > 0 then
  FreeLibrary(ManejDLL);

{Cerramos la vista del fichero y el fichero}
{Close the memfile and the View}
if FichMem > 0 then
begin
   UnmapViewOfFile(PuntRecept);
   CloseHandle(FichMem);
end;

end;

{ Llegan las teclas pulsadas en Ganchos.dll }
procedure TVent.LlegaDelGanchoDeTeclado(var message: TMessage);
var
  mVenAct : array[0..100] of char;
  mNomTec : array[0..100] of char;

begin

  GetWindowText(message.WParam, mVenAct, 100);
  GetKeyNameText(Message.LParam,mNomTec,100);

  LisIte := LiPuVi.Items.Add;
  LisIte.Caption := IntToStr(message.WParam);
  LisIte.SubItems.Add(mVenAct);
  LisIte.SubItems.Add('Tecla ' + mNomTec);

end;

{ Llegan los clicks pulsadoss en Ganchos.dll }
procedure TVent.LlegaDelGanchoDeRaton(var message: TMessage);
var
//  vMouseInfo: PMouseHookStruct;
  mVenAct : array[0..100] of char;

begin

  OutputDebugString(pwidechar(message.WParam));

{  vMouseInfo := PMouseHookStruct(message.lParam);
  GetWindowText(vMouseInfo.hwnd, mVenAct, 100);

  LisIte := LiPuVi.Items.Add;
  LisIte.Caption := IntToStr(vMouseInfo.hwnd);
  LisIte.SubItems.Add(mVenAct);}

end;

end.

Código Delphi [-]

{DFM}

object Vent: TVent
  Left = 0
  Top = 0
  Caption = 'Gesti'#243'n de simulaci'#243'n'
  ClientHeight = 280
  ClientWidth = 572
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = CrearForm
  OnDestroy = DestruirForm
  PixelsPerInch = 96
  TextHeight = 13
  object LiPuVi: TListView
    Left = 16
    Top = 24
    Width = 537
    Height = 235
    Columns = <
      item
        Width = 0
      end
      item
        Caption = 'Ventana del evento'
        Width = 150
      end
      item
        Caption = 'Pulsaci'#243'n'
        Width = 75
      end
      item
        Width = 300
      end>
    TabOrder = 0
    ViewStyle = vsReport
  end
end

[jocaro]

Hola.

Creo haber encontrado la explicación, que detallo a continuación por si el código es de ayuda para alguien.

La recogida de las pulsaciónes de ratón no se producía debido a que el entorno de desarrollo (XE2), estaba en modo 'debug' (entiendo que el propio debug estaba tratando esas pulsaciones). He cambiado a modo 'release'.

Incluso alguna instrucción OutputDebugString( 'cadena' ) daba problemas y he debido quitarla del programa, aun estando en modo 'release'.

Una vez hecho lo anterior me ha funcionado la recepción del comportamiento del ratón.

Eso si de manera muy burda ya que estaba intentando que funcionara y no tiene ningún condicionamiento en la función callback de la dll, asi que entiendo que entran todos los eventos de ratón que se producen, movimientos, click, etc.

Gracias por vuestra atención. Un saludo