unit KontrolaAplikacji;

interface

uses
  SysUtils, Classes, UruchamianieAplikacji, PobieranieUchwytuOkna, Windows;

type
  TControlProcess = class(TCreateProcess)
  private
    { Private declarations }
    function GetExecuted :Boolean;
    function GetWindowHandle :THandle;
    //Priorytet procesu
    function GetPriority :TPriorities;
    procedure SetPriority(APriority :TPriorities);
    //Etykieta okna
    function GetCaption :String;
    procedure SetCaption(ACaption :String);
    //Polozenie okna
    procedure PobierzPozycjeOkna;
    procedure UstawPozycjeOkna;
    function GetLeft :Integer;
    function GetTop :Integer;
    function GetWidth :Integer;
    function GetHeight :Integer;
    function GetWindowStyle :TWindowStyles;
    procedure SetLeft(ALeft :Integer);
    procedure SetTop(ATop :Integer);
    procedure SetWidth(AWidth :Integer);
    procedure SetHeight(AHeight :Integer);
    procedure SetWindowStyle(AWindowStyle :TWindowStyles);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    function Execute :Boolean;
    procedure BringToFront;
    procedure Terminate;
  published
    { Published declarations }
    property IsExecuted :Boolean read GetExecuted;
    property WindowHandle :THandle read GetWindowHandle;

    //Teraz mozna przypisac ProcessInformation. Pozwala to na kontrole aplikacji uruchomionych nie przez metode Execute
    property ProcessInformation :TProcessInformation read FProcessInformation write FProcessInformation;

    //nowa własność
    property Caption :String read GetCaption write SetCaption;

    //nadpisane
    property Priority :TPriorities read GetPriority write SetPriority nodefault;
    property Left :Integer read GetLeft write SetLeft;
    property Top :Integer read GetTop write SetTop;
    property Width :Integer read GetWidth write SetWidth;
    property Height :Integer read GetHeight write SetHeight;
    property WindowStyle :TWindowStyles read GetWindowStyle write SetWindowStyle nodefault;
  end;

procedure Register;

implementation

const MAX_COUNT=256;
type CString=array[0..MAX_COUNT-1] of Char;

constructor TControlProcess.Create(AOwner: TComponent);
begin
Inherited Create(AOwner);
end;

function TControlProcess.Execute :Boolean;
const CzasUruchomienia=60; //w sekundach
begin
//Nie mozna uruchomic drugiej aplikacji
if IsExecuted then raise Exception.Create('Aplikacja jest juz uruchomiona.');
//Wywolywanie TCreateProcess.Execute
Result:=Inherited Execute;
//Czekanie na zakonczenie inicjacji aplikacji (nie dziala np. dla cmd.exe)
case WaitForInputIdle(ProcessInformation.hProcess,1000*CzasUruchomienia) of
  0 :Result:=True;
  WAIT_FAILED,WAIT_TIMEOUT: Result:=False;
  end;
end;

procedure TControlProcess.BringToFront;
begin
if IsExecuted then BringWindowToTop(WindowHandle);
end;

procedure TControlProcess.Terminate;
begin
if IsExecuted then TerminateProcess(ProcessInformation.hProcess,0);
FillChar(FProcessInformation,sizeof(TProcessInformation),0); //czysci ProcessInformation
end;

function TControlProcess.GetExecuted :Boolean;
begin
Result:=True;
if WindowHandle=0 then //aplikacja zostala zamknieta
  begin
  FProcessInformation.dwProcessId:=0;
  FProcessInformation.hProcess:=0;
  FProcessInformation.dwThreadId:=0;
  FProcessInformation.hThread:=0;
  end;
if ProcessInformation.dwProcessId=0 then
  begin
  Result:=False;
  Exit;
  end
end;

function TControlProcess.GetWindowHandle :THandle;
begin
Result:=GetMainWindowHandle(ProcessInformation.dwProcessId);
end;

function TControlProcess.GetPriority :TPriorities;
var LPriority :Cardinal;
begin
if IsExecuted then
  Result:=FPriority
  else
  begin
  //ta konstrukcja jest wymuszona przez mechanizm kontroli wartosci wbudowany w typ wyliczeniowy
  LPriority:=GetPriorityClass(ProcessInformation.hProcess);
  case LPriority of
    Cardinal(prIdle): FPriority:=prIdle;
    Cardinal(prBelowNormal): FPriority:=prBelowNormal;
    Cardinal(prNormal): FPriority:=prNormal;
    Cardinal(prAboveNormal): FPriority:=prAboveNormal;
    Cardinal(prHigh): FPriority:=prHigh;
    Cardinal(prRealtime): FPriority:=prRealtime;
    else raise Exception.Create('Nierozpoznana klasa priorytetu');
  end;
  Result:=FPriority;
  end;
end;

procedure TControlProcess.SetPriority(APriority :TPriorities);
begin
if not IsExecuted then
  FPriority:=APriority
  else
  if SetPriorityClass(ProcessInformation.hProcess,Cardinal(APriority)) then
    FPriority:=APriority;
end;

//To dziala tylko po uruchomieniu aplikacji
function TControlProcess.GetCaption :String;
var LCaption :CString;
begin
if not IsExecuted then Exit;
GetWindowText(WindowHandle,LCaption,MAX_COUNT);
Result:=LCaption;
end;

procedure TControlProcess.SetCaption(ACaption :String);
begin
if not IsExecuted then Exit;
SetWindowText(WindowHandle,PChar(ACaption));
end;

procedure TControlProcess.PobierzPozycjeOkna;
var ustawieniaOkna :TWindowPlacement;
begin
GetWindowPlacement(WindowHandle,@ustawieniaOkna);
FLeft:=ustawieniaOkna.rcNormalPosition.Left;
FTop:=ustawieniaOkna.rcNormalPosition.Top;
FWidth:=ustawieniaOkna.rcNormalPosition.Right-ustawieniaOkna.rcNormalPosition.Left;
FHeight:=ustawieniaOkna.rcNormalPosition.Bottom-ustawieniaOkna.rcNormalPosition.Top;
FWindowStyle:=TWindowStyles(ustawieniaOkna.showCmd);
end;

procedure TControlProcess.UstawPozycjeOkna;
var ustawieniaOkna :TWindowPlacement;
begin
ustawieniaOkna.rcNormalPosition.Left:=FLeft;
ustawieniaOkna.rcNormalPosition.Top:=FTop;
ustawieniaOkna.rcNormalPosition.Right:=FLeft+FWidth;
ustawieniaOkna.rcNormalPosition.Bottom:=FTop+FHeight;
ustawieniaOkna.showCmd:=Integer(FWindowStyle);
ustawieniaOkna.length:=SizeOf(ustawieniaOkna);
SetWindowPlacement(WindowHandle,@ustawieniaOkna);
end;

function TControlProcess.GetLeft :Integer;
begin
if IsExecuted then PobierzPozycjeOkna;
Result:=FLeft;
end;

function TControlProcess.GetTop :Integer;
begin
if IsExecuted then PobierzPozycjeOkna;
Result:=FTop;
end;

function TControlProcess.GetWidth :Integer;
begin
if IsExecuted then PobierzPozycjeOkna;
Result:=FWidth;
end;

function TControlProcess.GetHeight :Integer;
begin
if IsExecuted then PobierzPozycjeOkna;
Result:=FHeight;
end;

function TControlProcess.GetWindowStyle :TWindowStyles;
begin
if IsExecuted then PobierzPozycjeOkna;
Result:=FWindowStyle;
end;

procedure TControlProcess.SetLeft(ALeft :Integer);
begin
FLeft:=ALeft;
if IsExecuted then UstawPozycjeOkna;
end;

procedure TControlProcess.SetTop(ATop :Integer);
begin
FTop:=ATop;
if IsExecuted then UstawPozycjeOkna;
end;

procedure TControlProcess.SetWidth(AWidth :Integer);
begin
FWidth:=AWidth;
if IsExecuted then UstawPozycjeOkna;
end;

procedure TControlProcess.SetHeight(AHeight :Integer);
begin
FHeight:=AHeight;
if IsExecuted then UstawPozycjeOkna;
end;

procedure TControlProcess.SetWindowStyle(AWindowStyle :TWindowStyles);
begin
FWindowStyle:=AWindowStyle;
if IsExecuted then UstawPozycjeOkna;
end;

procedure Register;
begin
  RegisterComponents('JM', [TControlProcess]);
end;

end.
