Эмуляция нажатия клавиши для любого активного приложения

Автор: VID

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Эмуляция нажатия клавиши

Функция SendKeys этого юнита, эмулиреут нажатие клавиши для лююого активного приложения
Для активизации приложения ивпользуйте функцию AppActivate

Зависимости: SysUtils, Windows, messages
Автор:       VID, vidsnap@mail.ru, ICQ:132234868, Махачкала
Copyright:   Автор неизвестен
Дата:        19 июня 2002 г.
***************************************************** }

unit SKUnit;

interface

uses SysUtils, Windows, messages;

function SendKeys(SendKeysString: PChar; Wait: Boolean): Boolean;
function AppActivate(WindowName: PChar): boolean;
const
  WorkBufLen = 40;
var
  WorkBuf: array[0..WorkBufLen] of Char;

implementation

type
  THKeys = array[0..pred(MaxLongInt)] of byte;
var
  AllocationSize: integer;

  (*
  Converts a string of characters and key names to keyboard events and
  passes them to Windows.

  Example syntax:

  SendKeys('abc123{left}{left}{left}def{end}456{left 6}ghi{end}789', True);

  *)

function SendKeys(SendKeysString: PChar; Wait: Boolean): Boolean;
type
  WBytes = array[0..pred(SizeOf(Word))] of Byte;

  TSendKey = record
    Name: ShortString;
    VKey: Byte;
  end;

const
  {Array of keys that SendKeys recognizes.

  If you add to this list, you must be sure to keep it sorted alphabetically
  by Name because a binary search routine is used to scan it.}

  MaxSendKeyRecs = 41;
  SendKeyRecs: array[1..MaxSendKeyRecs] of TSendKey =
  (
    (Name: 'BKSP'; VKey: VK_BACK),
    (Name: 'BS'; VKey: VK_BACK),
    (Name: 'BACKSPACE'; VKey: VK_BACK),
    (Name: 'BREAK'; VKey: VK_CANCEL),
    (Name: 'CAPSLOCK'; VKey: VK_CAPITAL),
    (Name: 'CLEAR'; VKey: VK_CLEAR),
    (Name: 'DEL'; VKey: VK_DELETE),
    (Name: 'DELETE'; VKey: VK_DELETE),
    (Name: 'DOWN'; VKey: VK_DOWN),
    (Name: 'END'; VKey: VK_END),
    (Name: 'ENTER'; VKey: VK_RETURN),
    (Name: 'ESC'; VKey: VK_ESCAPE),
    (Name: 'ESCAPE'; VKey: VK_ESCAPE),
    (Name: 'F1'; VKey: VK_F1),
    (Name: 'F10'; VKey: VK_F10),
    (Name: 'F11'; VKey: VK_F11),
    (Name: 'F12'; VKey: VK_F12),
    (Name: 'F13'; VKey: VK_F13),
    (Name: 'F14'; VKey: VK_F14),
    (Name: 'F15'; VKey: VK_F15),
    (Name: 'F16'; VKey: VK_F16),
    (Name: 'F2'; VKey: VK_F2),
    (Name: 'F3'; VKey: VK_F3),
    (Name: 'F4'; VKey: VK_F4),
    (Name: 'F5'; VKey: VK_F5),
    (Name: 'F6'; VKey: VK_F6),
    (Name: 'F7'; VKey: VK_F7),
    (Name: 'F8'; VKey: VK_F8),
    (Name: 'F9'; VKey: VK_F9),
    (Name: 'HELP'; VKey: VK_HELP),
    (Name: 'HOME'; VKey: VK_HOME),
    (Name: 'INS'; VKey: VK_INSERT),
    (Name: 'LEFT'; VKey: VK_LEFT),
    (Name: 'NUMLOCK'; VKey: VK_NUMLOCK),
    (Name: 'PGDN'; VKey: VK_NEXT),
    (Name: 'PGUP'; VKey: VK_PRIOR),
    (Name: 'PRTSC'; VKey: VK_PRINT),
    (Name: 'RIGHT'; VKey: VK_RIGHT),
    (Name: 'SCROLLLOCK'; VKey: VK_SCROLL),
    (Name: 'TAB'; VKey: VK_TAB),
    (Name: 'UP'; VKey: VK_UP)
    );

  {Extra VK constants missing from Delphi's Windows API interface}
  VK_NULL = 0;
  VK_SemiColon = 186;
  VK_Equal = 187;
  VK_Comma = 188;
  VK_Minus = 189;
  VK_Period = 190;
  VK_Slash = 191;
  VK_BackQuote = 192;
  VK_LeftBracket = 219;
  VK_BackSlash = 220;
  VK_RightBracket = 221;
  VK_Quote = 222;
  VK_Last = VK_Quote;

  ExtendedVKeys: set of byte =
  [VK_Up,
    VK_Down,
    VK_Left,
    VK_Right,
    VK_Home,
    VK_End,
    VK_Prior, {PgUp}
  VK_Next, {PgDn}
  VK_Insert,
    VK_Delete];

const
  INVALIDKEY = $FFFF {Unsigned -1};
  VKKEYSCANSHIFTON = $01;
  VKKEYSCANCTRLON = $02;
  VKKEYSCANALTON = $04;
  UNITNAME = 'SendKeys';
var
  UsingParens, ShiftDown, ControlDown, AltDown, FoundClose: Boolean;
  PosSpace: Byte;
  I, L: Integer;
  NumTimes, MKey: Word;
  KeyString: string[20];

  procedure DisplayMessage(Message: PChar);
  begin
    MessageBox(0, Message, UNITNAME, 0);
  end;

  function BitSet(BitTable, BitMask: Byte): Boolean;
  begin
    Result := ByteBool(BitTable and BitMask);
  end;

  procedure SetBit(var BitTable: Byte; BitMask: Byte);
  begin
    BitTable := BitTable or Bitmask;
  end;

  procedure KeyboardEvent(VKey, ScanCode: Byte; Flags: Longint);
  var
    KeyboardMsg: TMsg;
  begin
    keybd_event(VKey, ScanCode, Flags, 0);
    if (Wait) then
      while (PeekMessage(KeyboardMsg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE)) do
      begin
        TranslateMessage(KeyboardMsg);
        DispatchMessage(KeyboardMsg);
      end;
  end;

  procedure SendKeyDown(VKey: Byte; NumTimes: Word; GenUpMsg: Boolean);
  var
    Cnt: Word;
    ScanCode: Byte;
    NumState: Boolean;
    KeyBoardState: TKeyboardState;
  begin
    if (VKey = VK_NUMLOCK) then
    begin
      NumState := ByteBool(GetKeyState(VK_NUMLOCK) and 1);
      GetKeyBoardState(KeyBoardState);
      if NumState then
        KeyBoardState[VK_NUMLOCK] := (KeyBoardState[VK_NUMLOCK] and not 1)
      else
        KeyBoardState[VK_NUMLOCK] := (KeyBoardState[VK_NUMLOCK] or 1);
      SetKeyBoardState(KeyBoardState);
      exit;
    end;

    ScanCode := Lo(MapVirtualKey(VKey, 0));
    for Cnt := 1 to NumTimes do
      if (VKey in ExtendedVKeys) then
      begin
        KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY);
        if (GenUpMsg) then
          KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)
      end
      else
      begin
        KeyboardEvent(VKey, ScanCode, 0);
        if (GenUpMsg) then
          KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
      end;
  end;

  procedure SendKeyUp(VKey: Byte);
  var
    ScanCode: Byte;
  begin
    ScanCode := Lo(MapVirtualKey(VKey, 0));
    if (VKey in ExtendedVKeys) then
      KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP)
    else
      KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
  end;

  procedure SendKey(MKey: Word; NumTimes: Word; GenDownMsg: Boolean);
  begin
    if (BitSet(Hi(MKey), VKKEYSCANSHIFTON)) then
      SendKeyDown(VK_SHIFT, 1, False);
    if (BitSet(Hi(MKey), VKKEYSCANCTRLON)) then
      SendKeyDown(VK_CONTROL, 1, False);
    if (BitSet(Hi(MKey), VKKEYSCANALTON)) then
      SendKeyDown(VK_MENU, 1, False);
    SendKeyDown(Lo(MKey), NumTimes, GenDownMsg);
    if (BitSet(Hi(MKey), VKKEYSCANSHIFTON)) then
      SendKeyUp(VK_SHIFT);
    if (BitSet(Hi(MKey), VKKEYSCANCTRLON)) then
      SendKeyUp(VK_CONTROL);
    if (BitSet(Hi(MKey), VKKEYSCANALTON)) then
      SendKeyUp(VK_MENU);
  end;

  {Implements a simple binary search to locate special key name strings}

  function StringToVKey(KeyString: ShortString): Word;
  var
    Found, Collided: Boolean;
    Bottom, Top, Middle: Byte;
  begin
    Result := INVALIDKEY;
    Bottom := 1;
    Top := MaxSendKeyRecs;
    Found := false;
    Middle := (Bottom + Top) div 2;
    repeat
      Collided := ((Bottom = Middle) or (Top = Middle));
      if (KeyString = SendKeyRecs[Middle].Name) then
      begin
        Found := True;
        Result := SendKeyRecs[Middle].VKey;
      end
      else
      begin
        if (KeyString > SendKeyRecs[Middle].Name) then
          Bottom := Middle
        else
          Top := Middle;
        Middle := (Succ(Bottom + Top)) div 2;
      end;
    until (Found or Collided);
    if (Result = INVALIDKEY) then
      DisplayMessage('Invalid Key Name');
  end;

  procedure PopUpShiftKeys;
  begin
    if (not UsingParens) then
    begin
      if ShiftDown then
        SendKeyUp(VK_SHIFT);
      if ControlDown then
        SendKeyUp(VK_CONTROL);
      if AltDown then
        SendKeyUp(VK_MENU);
      ShiftDown := false;
      ControlDown := false;
      AltDown := false;
    end;
  end;

begin
  AllocationSize := MaxInt;
  Result := false;
  UsingParens := false;
  ShiftDown := false;
  ControlDown := false;
  AltDown := false;
  I := 0;
  L := StrLen(SendKeysString);
  if (L > AllocationSize) then
    L := AllocationSize;
  if (L = 0) then
    Exit;

  case SendKeysString[I] of
    '(':
      begin
        UsingParens := True;
        Inc(I);
      end;
    ')':
      begin
        UsingParens := False;
        PopUpShiftKeys;
        Inc(I);
      end;
    '%':
      begin
        AltDown := True;
        SendKeyDown(VK_MENU, 1, False);
        Inc(I);
      end;
    '+':
      begin
        ShiftDown := True;
        SendKeyDown(VK_SHIFT, 1, False);
        Inc(I);
      end;
    '^':
      begin
        ControlDown := True;
        SendKeyDown(VK_CONTROL, 1, False);
        Inc(I);
      end;
    '{':
      begin
        NumTimes := 1;
        if (SendKeysString[Succ(I)] = '{') then
        begin
          MKey := VK_LEFTBRACKET;
          SetBit(Wbytes(MKey)[1], VKKEYSCANSHIFTON);
          SendKey(MKey, 1, True);
          PopUpShiftKeys;
          Inc(I, 3);
          // Continue;
        end;
        KeyString := '';
        FoundClose := False;
        while (I <= L) do
        begin
          Inc(I);
          if (SendKeysString[I] = '}') then
          begin
            FoundClose := True;
            Inc(I);
            Break;
          end;
          KeyString := KeyString + Upcase(SendKeysString[I]);
        end;
        if (not FoundClose) then
        begin
          DisplayMessage('No Close');
          Exit;
        end;
        if (SendKeysString[I] = '}') then
        begin
          MKey := VK_RIGHTBRACKET;
          SetBit(Wbytes(MKey)[1], VKKEYSCANSHIFTON);
          SendKey(MKey, 1, True);
          PopUpShiftKeys;
          Inc(I);
          // Continue;
        end;
        PosSpace := Pos(' ', KeyString);
        if (PosSpace <> 0) then
        begin
          NumTimes := StrToInt(Copy(KeyString, Succ(PosSpace), Length(KeyString)
            - PosSpace));
          KeyString := Copy(KeyString, 1, Pred(PosSpace));
        end;
        if (Length(KeyString) = 1) then
          MKey := vkKeyScan(KeyString[1])
        else
          MKey := StringToVKey(KeyString);
        if (MKey <> INVALIDKEY) then
        begin
          SendKey(MKey, NumTimes, True);
          PopUpShiftKeys;
          // Continue;
        end;
      end;
    '~':
      begin
        SendKeyDown(VK_RETURN, 1, True);
        PopUpShiftKeys;
        Inc(I);
      end;
  else
    begin
      MKey := vkKeyScan(SendKeysString[I]);
      if (MKey <> INVALIDKEY) then
      begin
        SendKey(MKey, 1, True);
        PopUpShiftKeys;
      end
      else
        DisplayMessage('Invalid KeyName');
      Inc(I);
    end;
  end;

  Result := true;
  PopUpShiftKeys;
end;

{AppActivate

This is used to set the current input focus to a given window using its
name. This is especially useful for ensuring a window is active before
sending it input messages using the SendKeys function. You can specify
a window's name in its entirety, or only portion of it, beginning from
the left.

}

var
  WindowHandle: HWND;

function EnumWindowsProc(WHandle: HWND; lParam: LPARAM): BOOL; export; stdcall;
const
  MAX_WINDOW_NAME_LEN = 80;
var
  WindowName: array[0..MAX_WINDOW_NAME_LEN] of char;
begin
  {Can't test GetWindowText's return value since some windows don't have a title}
  GetWindowText(WHandle, WindowName, MAX_WINDOW_NAME_LEN);
  Result := (StrLIComp(WindowName, PChar(lParam), StrLen(PChar(lParam))) <> 0);
  if (not Result) then
    WindowHandle := WHandle;
end;

function AppActivate(WindowName: PChar): boolean;
begin
  try
    Result := true;
    WindowHandle := FindWindow(nil, WindowName);
    if (WindowHandle = 0) then
      EnumWindows(@EnumWindowsProc, Integer(PChar(WindowName)));
    if (WindowHandle <> 0) then
    begin
      SendMessage(WindowHandle, WM_SYSCOMMAND, SC_HOTKEY, WindowHandle);
      SendMessage(WindowHandle, WM_SYSCOMMAND, SC_RESTORE, WindowHandle);
    end
    else
      Result := false;
  except
    on Exception do
      Result := false;
  end;
end;

end.

Пример использования:

SendKeys('A', False);