{$C FIXED PRELOAD PERMANENT}

library mkbmouse;

uses
  Windows, messages, sysUtils, classes;

const
    SHIFT_KEY   = $2A10;
    CONTROL_KEY = $1D11;
    ALT_KEY     = $3812;

type
  TwParam = Word;
  TlParam = Longint;

type
  PEventMsg = ^TEventMsg;
  TMsgBuff = Array[0..6000]of TEventMsg;

var
  PMsgBuff: ^TMsgBuff;
  TheHook: HHook;

  StartTime: DWord;
  MaxMsg, MsgCount: Longint;
  MsgTime: Longint;
  CurrentMsg: Longint;
  SysModalOn: Bool;

{-------------------------------------------------------------}
{             executa os comandos armazenados
{-------------------------------------------------------------}

function PlaybackProc(Code: Integer;
                wParam: TwParam; lParam: TlParam): Longint; stdcall;
var
    TimeToFire: Longint;

begin
    PlaybackProc := 0;
    case Code of

        HC_SKIP:
        begin
            Inc(CurrentMsg);
            if CurrentMsg >= (MsgCount-1) then
              if TheHook <> 0 then
                if UnHookWindowsHookEx(TheHook) = True then
                  begin
                    TheHook := 0;
                    FreeMem(PMsgBuff, Sizeof(TMsgBuff));
                    PMsgBuff := nil;
                  end;
            exit;
        end;

        HC_GETNEXT:
        begin
          PEventMsg(lParam)^ := PMsgBuff^[CurrentMsg];
          PEventMsg(lParam)^.Time := StartTime + PMsgBuff^[CurrentMsg].Time;
          TimeToFire := PEventMsg(lParam)^.Time - GetTickCount;
          if TimeToFire > 0 then
              PlaybackProc := TimeToFire;
          exit;
        end;

        HC_SYSMODALON:      {something is wrong}
        begin
          SysModalOn := True;
          CallNextHookEx(TheHook, Code, wParam, lParam);
          exit;
        end;

        HC_SYSMODALOFF:      {we have been hosed by the system - our hook has been pulled!}
        begin
          SysModalOn := False;
          TheHook := 0;
          FreeMem(PMsgBuff, Sizeof(TMsgBuff));
          PMsgBuff := nil;
          CallNextHookEx(TheHook, Code, wParam, lParam);
          exit;
        end;
    end;

    If code < 0  then
      PlaybackProc := CallNextHookEx(TheHook, Code, wParam, lParam);
end;

{--------------------------------------------------------}
{           rotina interna de inserção no buffer
{--------------------------------------------------------}

procedure insertEvent (command: word; key: word);
begin
    with PMsgBuff^[msgCount] do
        begin
            message := command;
            paramL := key;
            paramH := 1;
            time := msgTime;
            msgTime := msgTime + 1;
            msgCount := msgCount + 1;
        end;
end;

{--------------------------------------------------------}
{      rotina de inserção de evento de baixo nível
{--------------------------------------------------------}

procedure playInsertKeyEvent (command: word; key: word;  delay: longint);
                                                                stdcall;
begin
    insertEvent (command, key);
    msgTime := msgTime + delay;
end;

{-------------------------------------------------------------}
{              inicia execução das tarefas
{-------------------------------------------------------------}

function PlayStart: boolean;  stdcall;
begin
    playStart := false;

    StartTime := GetTickCount;
    msgTime := 0;
    CurrentMsg := 0;

    TheHook := SetWindowsHookEx(WH_JOURNALPLAYBACK, @playBackProc, hInstance, 0);
    if TheHook = 0 then
        begin
            if maxMsg <> 0 then
                FreeMem(PMsgBuff, Sizeof(TEventMsg) * maxMsg);
            maxMsg := 0;
            PMsgBuff := nil;
            exit;
        end;

    playStart := true;
end;

{-------------------------------------------------------------}
{                  ve se ainda tocando
{-------------------------------------------------------------}

function PlayIsActive: boolean;  stdcall;
var M: TMsg;
begin
    playIsActive := theHook <> 0;
    while PeekMessage(M, 0, 0, 0, pm_Remove) do
       begin
          TranslateMessage(M);
          DispatchMessage(M);
       end;
end;

{-------------------------------------------------------------}
{              inicializa variáveis
{-------------------------------------------------------------}

function PlayInit (nMsg: integer): boolean;   stdcall;
begin
    playInit := false;
    if PMsgBuff <> nil then exit;   { double hook not allowed }

    maxMsg := nMsg;
    getMem (PMsgBuff, Sizeof(TEventMsg) * maxMsg);
    if PMsgBuff = nil then exit;

    msgCount := 0;
    SysModalOn := False;

    playInit := true;
end;

{-------------------------------------------------------------}
{               insere uma tecla virtual no buffer
{-------------------------------------------------------------}

procedure playVirtKey (key: byte; comCtl, comShift, comAlt: boolean; delay: longint);  stdcall;
var code: longint;
begin
    code := oemKeyScan (key);
    code := (code and $ffff) shl 8 + key;

    if comShift then  insertEvent (WM_KEYDOWN, SHIFT_KEY);
    if comCtl   then  insertEvent (WM_KEYDOWN, CONTROL_KEY);
    if comAlt then
        begin
            insertEvent (WM_SYSKEYDOWN, ALT_KEY);
            insertEvent (WM_SYSKEYDOWN, code);
            insertEvent (WM_SYSKEYUP, code);
            insertEvent (WM_SYSKEYUP, ALT_KEY);
        end
    else
        begin
            insertEvent (WM_KEYDOWN, code);
            insertEvent (WM_KEYUP, code);
        end;
    if comCtl   then  insertEvent (WM_KEYUP, CONTROL_KEY);
    if comShift then  insertEvent (WM_KEYUP, SHIFT_KEY);

    msgTime := msgTime + delay;
end;

{-------------------------------------------------------------}
{               insere uma tecla no buffer
{-------------------------------------------------------------}

procedure playKey (key: char; delay: longint);  stdcall;
var code: dword;
    comCtl, comShift: boolean;

begin
    if msgCount+1 >= maxMsg then exit;

    if not (key in [#0..#$1f, 'a'..'z']) then
        begin
            insertEvent (WM_CHAR, ord(key));
            msgTime := msgTime + delay;
            exit;
        end;

    code := oemKeyScan (ord(key));
    comShift := (code and $00020000) <> 0;
    comCtl   := (code and $00040000) <> 0;
    code := (code and $ffff) shl 8 + vkKeyScan (key);

    if comCtl   then  insertEvent (WM_KEYDOWN, CONTROL_KEY);
    if comShift then  insertEvent (WM_KEYDOWN, SHIFT_KEY);
    insertEvent (WM_KEYDOWN, code);
    insertEvent (WM_KEYUP, code);
    if comShift then  insertEvent (WM_KEYUP, SHIFT_KEY);
    if comCtl   then  insertEvent (WM_KEYUP, CONTROL_KEY);

    msgTime := msgTime + delay;
end;

{-------------------------------------------------------------}
{               insere uma tecla alt no buffer
{-------------------------------------------------------------}

procedure playAltKey (key: char; delay: longint);  stdcall;
var code: longint;
    comCtl: boolean;
begin
    code := oemKeyScan (ord (key));
    comCtl   := (code and $00040000) <> 0;
    code := (code and $ffff) shl 8 + vkKeyScan (key);

    if comCtl   then  insertEvent (WM_KEYDOWN, CONTROL_KEY);
    insertEvent (WM_SYSKEYDOWN, ALT_KEY);
    insertEvent (WM_SYSKEYDOWN, code);
    insertEvent (WM_SYSKEYUP, code);
    insertEvent (WM_SYSKEYUP, ALT_KEY);
    if comCtl   then  insertEvent (WM_KEYUP, CONTROL_KEY);

    msgTime := msgTime + delay;
end;

{--------------------------------------------------------}
{              insere uma cadeia no buffer
{--------------------------------------------------------}

procedure playString (p: pchar; delay: longint);  stdcall;
var i: integer;
begin
    for i := 0 to strlen(p)-1 do
        playKey (p[i], delay);
end;

{--------------------------------------------------------}
{              insere um evento de mouse
{--------------------------------------------------------}

procedure playMouse (command, x, y: word; delay: longint);  stdcall;
begin
    with PMsgBuff^[msgCount] do
        begin
            message := command;
            paramL := x;
            paramH := y;
            time := msgTime;
            msgTime := msgTime + delay;
            msgCount := msgCount + 1;
        end;
end;

exports
    playbackProc name 'PLAYBACKPROC',
    PlayInit     name 'PLAYINIT',
    PlayStart    name 'PLAYSTART',
    PlayIsActive name 'PLAYISACTIVE',
    playKey      name 'PLAYKEY',
    playAltKey   name 'PLAYALTKEY',
    playVirtKey  name 'PLAYVIRTKEY',
    playString   name 'PLAYSTRING',
    playInsertKeyEvent
                 name 'PLAYINSERTKEYEVENT',
    playMouse    name 'PLAYMOUSE';

begin
  PMsgBuff := nil;
  theHook := 0;
end.