sendkey.pas

《Delphi开发人员指南》配书原码

unit SendKey;

interface

uses
 SysUtils, Windows, Messages, Classes, KeyDefs;

type
  { Error codes }
  TSendKeyError = (sk_None, sk_FailSetHook, sk_InvalidToken,
    sk_UnknownError, sk_AlreadyPlaying);
  { first vk code to last vk code }
  TvkKeySet = set of vk_LButton..vk_Scroll;

  { exceptions }
  ESendKeyError = class(Exception);
  ESKSetHookError = class(ESendKeyError);
  ESKInvalidToken = class(ESendKeyError);
  ESKAlreadyPlaying = class(ESendKeyError);

function SendKeys(S: String): TSendKeyError;
procedure WaitForHook;
procedure StopPlayback;

var
  Playing: Boolean;

implementation

uses Forms;

type
  { a TList descendant that know how to dispose of its contents }
  TMessageList = class(TList)
  public
    destructor Destroy; override;
  end;

const
  { valid "sys" keys }
  vkKeySet: TvkKeySet = [Ord('A')..Ord('Z'), vk_Menu, vk_F1..vk_F12];

destructor TMessageList.Destroy;
var
  i: longint;
begin
  { deallocate all the message records before discarding the list }
  for i := 0 to Count - 1 do
    Dispose(PEventMsg(Items[i]));
  inherited Destroy;
end;

var
  { variables global to the DLL }
  MsgCount: word = 0;
  MessageBuffer: TEventMsg;
  HookHandle: hHook = 0;
  MessageList: TMessageList = Nil;
  AltPressed, ControlPressed, ShiftPressed: Boolean;

procedure StopPlayback;
{ Unhook the hook, and clean up }
begin
  { if Hook is currently active, then unplug it }
  if Playing then
    UnhookWindowsHookEx(HookHandle);
  MessageList.Free;
  Playing := False;
end;

function Play(Code: integer; wParam, lParam: Longint): Longint; stdcall;
{ This is the JournalPlayback callback function.  It is called by }
{ Windows when Windows polls for hardware events.  The code parameter }
{ indicates what to do. }
begin
  case Code of
    HC_SKIP:
      { HC_SKIP means to pull the next message out of our list. If we }
      { are at the end of the list, it's okay to unhook the }
      { JournalPlayback hook from here. }
      begin
        { increment message counter }
        inc(MsgCount);
        { check to see if all messages have been played }
        if MsgCount >= MessageList.Count then StopPlayback
        { otherwise copy next message from list into buffer }
        else MessageBuffer := TEventMsg(MessageList.Items[MsgCount]^);
        Result := 0;
      end;
    HC_GETNEXT:
      { HC_GETNEXT means to fill the wParam and lParam with the proper }
      { values so that the message can be played back.  DO NOT unhook }
      { hook from within here.  Return value indicates how much time }
      { until Windows should playback message.  We'll return 0 so that }
      { it is processed right away. }
      begin
        { move message in buffer to message queue }
        PEventMsg(lParam)^ := MessageBuffer;
        Result := 0  { process immediately }
      end
    else
      { if Code isn't HC_SKIP or HC_GETNEXT, call next hook in chain }
      Result := CallNextHookEx(HookHandle, Code, wParam, lParam);
  end;
end;

procedure StartPlayback;
{ Initializes globals and sets the hook }
begin
  { grab first message from list and place in buffer in case we }
  { get a hc_GetNext before and hc_Skip }
  MessageBuffer := TEventMsg(MessageList.Items[0]^);
  { initialize message count and play indicator }
  MsgCount := 0;
  { initialize Alt, Control, and Shift key flags }
  AltPressed := False;
  ControlPressed := False;
  ShiftPressed := False;
  { set the hook! }
  HookHandle := SetWindowsHookEx(wh_JournalPlayback, Play, hInstance, 0);
  if HookHandle = 0 then
    raise ESKSetHookError.Create('Failed to set hook');
  Playing := True;
end;

procedure MakeMessage(vKey: byte; M: Cardinal);
{ procedure builds a TEventMsg record that emulates a keystroke and }
{ adds it to message list }
var
  E: PEventMsg;
begin
  New(E);                                 // allocate a message record
  with E^ do
  begin
    message := M;                         // set message field
    paramL := vKey;                       // vk code in ParamL
    paramH := MapVirtualKey(vKey, 0);     // scan code in ParamH
    time := GetTickCount;                 // set time
    hwnd := 0;                            // ignored
  end;
  MessageList.Add(E);
end;

procedure KeyDown(vKey: byte);
{ Generates KeyDownMessage }
begin
  { don't generate a "sys" key if the control key is pressed }
  { (This is a Windows quirk) }
  if AltPressed and (not ControlPressed) and  (vKey in vkKeySet) then
    MakeMessage(vKey, wm_SysKeyDown)
  else
    MakeMessage(vKey, wm_KeyDown);
end;

procedure KeyUp(vKey: byte);
{ Generates KeyUp message }
begin
  { don't generate a "sys" key if the control key is pressed }
  { (This is a Windows quirk) }
  if AltPressed and (not ControlPressed) and (vKey in vkKeySet) then
    MakeMessage(vKey, wm_SysKeyUp)
  else
    MakeMessage(vKey, wm_KeyUp);
end;

procedure SimKeyPresses(VKeyCode: Word);
{ This function simulates keypresses for the given key, taking into }
{ account the current state of Alt, Control, and Shift keys }
begin
  { press Alt key if flag has been set }
  if AltPressed then
    KeyDown(vk_Menu);
  { press Control key if flag has been set }
  if ControlPressed then
    KeyDown(vk_Control);
  { if shift is pressed, or shifted key and control is not pressed... }
  if (((Hi(VKeyCode) and 1) <> 0) and (not ControlPressed)) or
    ShiftPressed then
    KeyDown(vk_Shift);    { ...press shift }
  KeyDown(Lo(VKeyCode));  { press key down }
  KeyUp(Lo(VKeyCode));    { release key }
  { if shift is pressed, or shifted key and control is not pressed... }
  if (((Hi(VKeyCode) and 1) <> 0) and (not ControlPressed)) or
    ShiftPressed then
    KeyUp(vk_Shift);      { ...release shift }
  { if shift flag is set, reset flag }
  if ShiftPressed then begin
    ShiftPressed := False;
  end;
  { Release Control key if flag has been set, reset flag }
  if ControlPressed then begin
    KeyUp(vk_Control);
    ControlPressed := False;
  end;
  { Release Alt key if flag has been set, reset flag }
  if AltPressed then begin
    KeyUp(vk_Menu);
    AltPressed := False;
  end;
end;

procedure ProcessKey(S: String);
{ This function parses each character in the string to create the }
{ message list }
var
  KeyCode: word;
  Key: byte;
  index: integer;
  Token: TKeyString;
begin
  index := 1;
  repeat
    case S[index] of
      KeyGroupOpen:
        { It's the beginning of a special token! }
        begin
          Token := '';
          inc(index);
          while S[index] <> KeyGroupClose do begin
            { add to Token until the end token symbol is encountered }
            Token := Token + S[index];
            inc(index);
            { check to make sure the token's not too long }
            if (Length(Token) = 7) and (S[index] <> KeyGroupClose) then
              raise ESKInvalidToken.Create('No closing brace');
          end;
          { look for token in array, Key parameter will }
          { contain vk code if successful }
          if not FindKeyInArray(Token, Key) then
            raise ESKInvalidToken.Create('Invalid token');
          { simulate keypress sequence }
          SimKeyPresses(MakeWord(Key, 0));
        end;
      AltKey: AltPressed := True;           // set Alt flag
      ControlKey: ControlPressed := True;   // set Control flag
      ShiftKey: ShiftPressed := True;       // set Shift flag
      else begin
      { A normal character was pressed }
        { convert character into a word where the high byte contains }
        { the shift state and the low byte contains the vk code }
        KeyCode := vkKeyScan(S[index]);
        { simulate keypress sequence }
        SimKeyPresses(KeyCode);
      end;
    end;
    Inc(index);
  until index > Length(S);
end;

procedure WaitForHook;
begin
  repeat Application.ProcessMessages until not Playing;
end;

function SendKeys(S: String): TSendKeyError;
{ This is the one entry point.  Based on the string passed in the S  }
{ parameter, this function creates a list of keyup/keydown messages, }
{ sets a JournalPlayback hook, and replays the keystroke messages.   }
begin
  Result := sk_None;                     // assume success
  try
    if Playing then raise ESKAlreadyPlaying.Create('');
    MessageList := TMessageList.Create;  // create list of messages
    ProcessKey(S);                       // create messages from string
    StartPlayback;                     // set hook and play back messages
  except
    { if an exception occurs, return an error code, and clean up }
    on E:ESendKeyError do
    begin
      MessageList.Free;
      if E is ESKSetHookError then
        Result := sk_FailSetHook
      else if E is ESKInvalidToken then
        Result := sk_InvalidToken
      else if E is ESKAlreadyPlaying then
        Result := sk_AlreadyPlaying;
    end
    else
      Result := sk_UnknownError;  // Catch-all exception handler
  end;
end;

end.