{$C FIXED PRELOAD PERMANENT}

library hkbmouse;

uses
  win31, WinTypes, WinProcs;

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: Longint;
  MaxMsg, MsgCount: Longint;
  MsgTime: Longint;
  CurrentMsg: Longint;
  SysModalOn: Bool;

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

function PlaybackProc(Code: Integer;
                wParam: TwParam; lParam: TlParam): Longint; export;
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);
                                                                export;
begin
    insertEvent (command, key);
    msgTime := msgTime + delay;
end;

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

function PlayStart: boolean;  export;
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;  export;
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;   export;
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 no buffer
{-------------------------------------------------------------}

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

const
    acento: array [#$c0..#$ff] of char = (
        '`', '''', '^', '~', '"', '_', '_', '''', '`', '''', '^', '"', '`', '''', '^', '"',
        '_', '~', '`', '''', '^', '~', '"', '_', '_', '`', '''', '^', '"', '''', '_', '_',
        '`', '''', '^', '~', '"', '_', '_', '''', '`', '''', '^', '"', '`', '''', '^', '"',
        '_', '~', '`', '''', '^', '~', '"', '_', '_', '`', '''', '^', '"', '''', '_', '_'
    );

    semacento: array [#$c0..#$ff] of char = (
         'A', 'A', 'A', 'A', 'A', 'A', 'E', 'C', 'E', 'E', 'E', 'E', 'I', 'I', 'I', 'I',
         'D', 'N', 'O', 'O', 'O', 'O', 'O', 'x', 'O', 'U', 'U', 'U', 'U', 'Y', '_', '_',
         'a', 'a', 'a', 'a', 'a', 'a', 'e', 'c', 'e', 'e', 'e', 'e', 'i', 'i', 'i', 'i',
         'd', 'n', 'o', 'o', 'o', 'o', 'o', '-', 'o', 'u', 'u', 'u', 'u', 'y', '_', '_'
    );

begin
    if key > #$c0 then
        begin
            playKey (acento [key], 1);
            key := semAcento [key];
        end;

    if msgCount+1 >= maxMsg then exit;

    code := oemKeyScan (ord(key));
    comShift := (code and $00020000) <> 0;
    comCtl   := (code and $00040000) <> 0;
    code := (code and $ffff) shl 8 + vkKeyScan (ord(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);  export;
var code: longint;
    comCtl: boolean;
begin
    code := oemKeyScan (ord (key));
    comCtl   := (code and $00040000) <> 0;
    code := (code and $ffff) shl 8 + vkKeyScan (ord(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 tecla virtual no buffer
{-------------------------------------------------------------}

procedure playVirtKey (key: byte; comCtl, comShift, comAlt: boolean; delay: longint);  export;
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 cadeia no buffer
{--------------------------------------------------------}

procedure playString (s: string; delay: longint);  export;
var i: integer;
begin
    for i := 1 to length (s) do
        playKey (s[i], delay);
end;

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

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

exports
    playbackProc index  1 name 'PLAYBACKPROC' resident,
    PlayInit     index  2 name 'PLAYINIT' resident,
    PlayStart    index  3 name 'PLAYSTART' resident,
    PlayIsActive index  4 name 'PLAYISACTIVE' resident,
    playKey      index  5 name 'PLAYKEY' resident,
    playAltKey   index  6 name 'PLAYALTKEY' resident,
    playVirtKey  index  7 name 'PLAYVIRTKEY' resident,
    playString   index  8 name 'PLAYSTRING' resident,
    playInsertKeyEvent
                 index  9 name 'PLAYINSERTKEYEVENT' resident,
    playMouse    index 10 name 'PLAYMOUSE' resident;

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