unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, Spin;
type
TForm1 =
class(TForm)
TerminateEdit1: TSpinEdit;
RunEdit1: TSpinEdit;
Timer1: TTimer;
lbl_CountDown1: TLabel;
lbl_Process1: TLabel;
B1_STRESS: TButton;
B1_STOP: TButton;
lbl_STATUS: TLabel;
Label1: TLabel;
procedure Timer1Timer(Sender: TObject);
procedure B1_STRESSClick(Sender: TObject);
procedure B1_STOPClick(Sender: TObject);
procedure FormShow(Sender: TObject);
private
FProcessInfo: TProcessInformation;
FAutoTermTime: TDateTime;
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure STRESS(
var fn:
String);
var
sProgram:
String;
zCommand:
array[0..512]
of char;
si: TStartupInfo;
dwError: DWORD;
begin
Form1.Timer1.Tag:=0;
sProgram := ExtractFilePath(Application.ExeName) + fn;
if (Pos('
', sProgram) > 0)
and (sProgram[1] <> '
"')
then
sProgram := AnsiQuotedStr(sProgram, '
"');
sProgram := sProgram + '
' + IntToStr(Form1.RunEdit1.Value);
// Add parameters
StrPCopy(zCommand, sProgram);
FillChar(si, SizeOf(si), #0);
si.cb := SizeOf(si);
si.dwFlags := STARTF_USESHOWWINDOW;
si.wShowWindow := SW_HIDE;
// SW_SHOWNORMAL;
[b]
// wie hier CORE 0, CORE 1 etc. bestimmen ???[/b]
if CreateProcess(
nil, zCommand,
nil,
nil, False,
CREATE_NEW_CONSOLE
or NORMAL_PRIORITY_CLASS,
nil,
nil, si, Form1.FProcessInfo)
then
begin
Form1.FAutoTermTime :=
Now + EncodeTime(0, Form1.TerminateEdit1.Value
div 60, Form1.TerminateEdit1.Value
mod 60, 0);
Form1.lbl_STATUS.Caption:=
Format('
STRESS - process created with handle %d, will auto-terminate at %s.',
[Form1.FProcessInfo.hProcess, DateTimeToStr(Form1.FAutoTermTime)]);
Form1.Timer1.Enabled := True;
end else begin
dwError := GetLastError;
Form1.lbl_STATUS.Caption:=
Format('
STRESS - CreateProcess failed with error %d', [dwError]);
end;
end;
procedure TForm1.B1_STOPClick(Sender: TObject);
var uExitCode: Cardinal; sAuto:
String; hProcess : Cardinal;
begin
uExitCode := 0;
hProcess:= StrToInt(lbl_Process1.caption);
if Sender
is TTimer
then sAuto := '
auto-'
else sAuto := '
';
if TerminateProcess(hProcess, uExitCode)
then
begin
Timer1.enabled:=false;
B1_STOP.Enabled:= false;
B1_STRESS.Enabled:= true;
lbl_CountDown1.Caption:='
-----';
lbl_Process1.Caption:='
-----';
lbl_STATUS.Caption:= Format('
Test %sterminated: exit code %d.', [sAuto, uExitCode]);
end else begin
uExitCode := GetLastError;
lbl_STATUS.Caption:= Format('
Test %sterminated: error code %d.', [sAuto, uExitCode]);
end;
end;
procedure TForm1.B1_STRESSClick(Sender: TObject);
var B1 :
String;
begin
Timer1.Tag:=0;
B1_STRESS.Enabled:= false;
B1:= '
STRESS.001';
STRESS(B1);
B1_STOP.Enabled:=true;
lbl_Process1.Caption:= IntToStr(FProcessInfo.hProcess);
lbl_STATUS.Caption:='
Running...';
end;
procedure TForm1.FormShow(Sender: TObject);
begin
lbl_STATUS.Caption:='
Waiting...';
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var ret: DWORD;
begin
Timer1.Tag:= Timer1.Tag +1;
lbl_CountDown1.caption:= IntToStr(TerminateEdit1.Value-Timer1.Tag)+'
sec';
ret := MsgWaitForMultipleObjects(
1,
{ 1 handle to wait on }
FProcessInfo.hProcess,
{ the handle }
False,
{ wake on any event }
5,
{ wait timeout (# or INFINITE) }
QS_PAINT
or { wake on paint messages }
QS_SENDMESSAGE
{ or messages from other threads }
);
if ret = WAIT_OBJECT_0
then begin
Timer1.Enabled := False;
B1_STOP.Enabled := False;
B1_STRESS.Enabled := True;
CloseHandle(FProcessInfo.hProcess);
CloseHandle(FProcessInfo.hThread);
lbl_STATUS.Caption:='
Not Running...';
end else begin
if Now >= FAutoTermTime
then B1_STOPClick(Sender);
end;
end;
end.