Посылаем нажатия клавиш другому приложению

Автор: Gert v.d. Venis
Компонент Sendkeys:

unit SendKeys;

interface

uses

 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

 TSendKeys = class(TComponent)

 private

  fhandle:HWND;

  L:Longint;

  fchild: boolean;

  fChildText: string;

  procedure SetIsChildWindow(const Value: boolean);

  procedure SetChildText(const Value: string);

  procedure SetWindowHandle(const Value: HWND);

 protected

 public

 published

  Procedure GetWindowHandle(Text:String);

  Procedure SendKeys(buffer:string);

  Property WindowHandle:HWND read fhandle write SetWindowHandle;

  Property IsChildWindow:boolean read fchild write SetIsChildWindow;

  Property ChildWindowText:string read fChildText write SetChildText;

 end;

procedure Register;

implementation

var temps:string;{й utilizado para ser acessivel pelas funcs q sao

  utilizadas como callbacks}


  HTemp:Hwnd;

  ChildText:string;

  ChildWindow:boolean;

procedure Register;

begin

 RegisterComponents('Standard', [TSendKeys]);

end;

{ TSendKeys }



function PRVGetChildHandle(H:HWND; L: Integer): LongBool;

var p:pchar;

  I:integer;

  s:string;

begin

 I:=length(ChildText)+2;

 GetMem(p,i+1);

 SendMessage(H,WM_GetText,i,integer(p));

 s:=strpcopy(p,s);

 if pos(ChildText,s)<>0 then

  begin

  HTemp:=H;

  Result:=False

  end else

  Result:=True;

 FreeMem(p);

end;

function PRVSendKeys(H: HWND; L: Integer): LongBool;stdcall;

var s:string;

  i:integer;

begin

 i:=length(temps);

 if i<>0 then

 begin

  SetLength(s,i+2);

  GetWindowText(H, pchar(s),i+2);

  if Pos(temps,string(s))<>0 then

  begin

  Result:=false;

  if ChildWindow then

  EnumChildWindows(H,@PRVGetChildHandle,L)

  else

  HTemp:=H;

  end

  else

  Result:=True;

 end else

  Result:=False;

end;

procedure TSendKeys.GetWindowHandle(Text: String);

begin

 temps:=Text;

 ChildText:=fChildText;

 ChildWindow:=fChild;

 EnumWindows(@PRVSendKeys,L);

 fHandle:=HTemp;

end;



procedure TSendKeys.SendKeys(buffer: string);

var i:integer;

  w:word;

  D:DWORD;

  P:^DWORD;

begin

 P:=@D;

 SystemParametersInfo( //get flashing timeout on win98

  SPI_GETFOREGROUNDLOCKTIMEOUT,

  0,

  P,

  0);

 SetForeGroundWindow(fHandle);

 for i:=1 to length(buffer) do

 begin

  w:=VkKeyScan(buffer[i]);

  keybd_event(w,0,0,0);

  keybd_event(w,0,KEYEVENTF_KEYUP,0);

 end;

 SystemParametersInfo( //set flashing TimeOut=0

  SPI_SETFOREGROUNDLOCKTIMEOUT,

  0,

  nil,

  0);

 SetForegroundWindow(TWinControl(TComponent(Self).Owner).Handle);

  //->typecast working...

 SystemParametersInfo( //set flashing TimeOut=previous value

  SPI_SETFOREGROUNDLOCKTIMEOUT,

  D,

  nil,

  0);

end;

procedure TSendKeys.SetChildText(const Value: string);

begin

 fChildText := Value;

end;

procedure TSendKeys.SetIsChildWindow(const Value: boolean);

begin

 fchild := Value;

end;

procedure TSendKeys.SetWindowHandle(const Value:HWND);

begin

 fHandle:=WindowHandle;

end;



end.

Описание:
Данный компонент получает хэндл(handle) любого запущенного окна и даёт возможность отправить по указанному хэндлу любые комбинации нажатия клавиш.
Совместимость: Все версии Delphi
Собственно сам исходничек:
После того, как проинсталируете этот компонент, создайте новое приложение и поместите на форму кнопку и сам компонент SendKeys. Добавьте следующий код в обработчик события OnClick кнопки:

procedure TForm1.Button1Click(Sender: TObject);

begin

// Запускаем Notepad, и ему мы будем посылать нажатия клавиш

WinExec('NotePad.exe', SW_SHOW);

// В параметре процедуры GetWindowHandle помещаем

// текст заголовка окна Notepad'а.

SendKeys1.GetWindowHandle('Untitled - Notepad');

// Если хэндл окна получен успешно, то отправляем ему текст

if SendKeys1.WindowHandle <> 0 then

SendKeys1.SendKeys('This is a test');

// Так же можно отправить код любой кнопки типа

// RETURN, используя следующий код:

// SendKeys1.SendKeys(Chr(13));

end;

---------------------------------
Неправда ли весело :)

Взято из http://forum.sources.ru

Отправить комментарий

Проверка
Антиспам проверка
Image CAPTCHA
...