procedure FormDestroy(Sender: TObject);
procedure ButtonStartClick(Sender: TObject);
procedure ButtonAbbruchClick(Sender: TObject);
procedure ButtonWeiterClick(Sender: TObject);
procedure ButtonEXITClick(Sender: TObject);
private
{ Private-Deklarationen }
CSection1 : TCriticalSection;
CSection2 : TCriticalSection;
UrlList : TStringList;
ErgebnisListe : TStringList;
ActiveThreads : Int64;
IdleJobs : Int64;
JobsFinished : Int64;
procedure UpdateLabelActiveThreads(Sender: TObject);
procedure UpdateLabelJobs(Sender: TObject);
procedure UpdateLabelFinished(Sender: TObject);
public
{ Public-Deklarationen }
end;
var
Form1 : TForm1;
ShouldStop : Boolean = False;
implementation
{$R *.dfm}
type
TURLCheckerThread =
class(TThread)
private
FUpdateAktiv : TNotifyEvent;
{<--- HIER}
FUpdateJobs : TNotifyEvent;
{<--- HIER}
FUpdateFertig : TNotifyEvent;
{<--- HIER}
FUrlList : TStrings;
FCSection1 : TCriticalSection;
FCSection2 : TCriticalSection;
FOnStatus : TProc<TstringList>;
FShouldStop : PBoolean;
FTimeOut : Word;
{<--- HIER}
protected
procedure Execute;
override;
procedure UpdateStatus(
const Msg: TstringList);
public
constructor Create(UrlList: TStrings; CSection1, CSection2: TCriticalSection; OnStatus: TProc<TstringList>; ShouldStop: PBoolean);
property OnUpdateActive : TNotifyEvent
read FUpdateAktiv
write FUpdateAktiv;
{<--- HIER}
property OnUpdateJobs : TNotifyEvent
read FUpdateJobs
write FUpdateJobs;
{<--- HIER}
property OnUpdateFertig : TNotifyEvent
read FUpdateFertig
write FUpdateFertig;
{<--- HIER}
property TimeOut : Word
read FTimeOut
write FTimeOut;
{<--- HIER}
end;
{ TWorkerThread }
constructor TURLCheckerThread.Create(UrlList: TStrings; CSection1, CSection2: TCriticalSection; OnStatus: TProc<TstringList>; ShouldStop: PBoolean);
begin
inherited Create(False);
FUrlList := UrlList;
FCSection1 := CSection1;
FCSection2 := CSection2;
FOnStatus := OnStatus;
FShouldStop := ShouldStop;
FreeOnTerminate := True;
end;
procedure TURLCheckerThread.UpdateStatus(
const Msg: TstringList);
begin
if Assigned(FOnStatus)
then
TThread.Synchronize(TThread.Current,
procedure begin FOnStatus(Msg);
end);
end;
procedure TURLCheckerThread.Execute;
var
FErgebnis : TstringList;
Url :
string;
Http : TIdHTTP;
begin
Http := TIdHTTP.Create(
nil);
Http.ConnectTimeout := FTimeOut;
// 8000
Http.ReadTimeout := FTimeOut;
try
while not Terminated
and not FShouldStop^
do
begin
Url := '
';
FCSection1.Acquire;
try
if FUrlList.Count > 0
then
begin
Url := FUrlList[0];
FUrlList.Delete(0);
end;
finally
FCSection1.Release;
end;
if Url = '
'
then Break;
Sleep(Random(2000));
{Hier kommt später meine Aufgabe}
FErgebnis := TStringList.Create;
try
try
// Http.Head(Url);
FCSection2.Acquire;
{Keine Ahnung ob es richtig ist, habe aber rausgelesen dass man StringList auf jeden Fall mit CriticalSection absichern soll}
try
FErgebnis.Add('
OK: ' +
Url);
{Ergebnis in StringList eintragen}
FErgebnis.Add('
Zweite Zeile');
FErgebnis.Add('
Dritte Zeile');
finally
FCSection2.Release;
end;
UpdateStatus(FErgebnis);
except
on E:
Exception do
begin
FErgebnis.Add('
FAIL: ' +
Url + '
- ' + E.
Message);
UpdateStatus(FErgebnis);
end;
end;
finally
FreeAndNil(FErgebnis);
end;
if Assigned(FUpdateJobs)
then
begin
TThread.Synchronize(
nil,
procedure
begin
FUpdateJobs(Self);
end);
end;
if Assigned(FUpdateFertig)
then
begin
TThread.Synchronize(
nil,
procedure
begin
FUpdateFertig(Self);
end);
end;
end;
finally
FreeAndNil(FErgebnis);
FreeAndNil(Http);
if Assigned(FUpdateAktiv)
then
begin
TThread.Synchronize(
nil,
procedure
begin
FUpdateAktiv(Self);
end);
end;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FreeAndNil(ErgebnisListe);
FreeAndNil(UrlList);
FreeAndNil(CSection1);
FreeAndNil(CSection2);
end;
procedure TForm1.ButtonStartClick(Sender: TObject);
var
Threads :
array[0..100]
of TURLCheckerThread;
Index : Integer;
begin
if Assigned(CSection1)
then FreeAndNil(CSection1);
{Falls ich nach Cancel noch mal Start drücke statt Weiter}
if Assigned(CSection2)
then FreeAndNil(CSection2);
if Assigned(UrlList)
then FreeAndNil(UrlList);
UrlList := TStringList.Create;
CSection1 := TCriticalSection.Create;
CSection2 := TCriticalSection.Create;
ShouldStop := False;
for Index := 0
to 200
do
begin
URLList.Add('
http://google.com/' + IntToStr(
Index));
end;
LabelJobs.Caption := '
100';
LabelIdle.Caption := '
100';
IdleJobs := 100;
Gauge1.MaxValue := 100;
Gauge1.Progress := 0;
JobsFinished := 0;
for Index := 1
to SpinEditThreads.Value
do
begin
Threads[
Index] := TURLCheckerThread.Create(UrlList, CSection1, CSection2,
procedure(Msg: TstringList)
var
ErgebnisListe : TStringList;
begin
RichEditLog.Lines.Add(Msg.Text);
{Ergebnis als StringList}
end, @ShouldStop);
Threads[
Index].TimeOut := SpinEditTimeout.Value;
Threads[
Index].OnUpdateActive := UpdateLabelActiveThreads;
Threads[
Index].OnUpdateJobs := UpdateLabelJobs;
Threads[
Index].OnUpdateFertig := UpdateLabelFinished;
{Zähle aktive Threads}
Inc(ActiveThreads);
LabelActiveThreads.Caption := IntToStr(ActiveThreads);
end;
end;
procedure TForm1.ButtonWeiterClick(Sender: TObject);
var
Threads :
array[0..100]
of TURLCheckerThread;
Index : Integer;
begin
ShouldStop := False;
for Index := 1
to SpinEditThreads.Value
do
begin
Threads[
Index] := TURLCheckerThread.Create(UrlList, CSection1, CSection2,
procedure(Msg: TstringList)
begin
RichEditLog.Lines.Add(Msg.Text);
{Ergebnis als StringList}
end, @ShouldStop);
Threads[
Index].TimeOut := SpinEditTimeout.Value;
Threads[
Index].OnUpdateActive := UpdateLabelActiveThreads;
Threads[
Index].OnUpdateJobs := UpdateLabelJobs;
Threads[
Index].OnUpdateFertig := UpdateLabelFinished;
{Zähle aktive Threads}
Inc(ActiveThreads);
LabelActiveThreads.Caption := IntToStr(ActiveThreads);
end;
end;
procedure TForm1.ButtonAbbruchClick(Sender: TObject);
begin
ShouldStop := True;
end;
procedure TForm1.ButtonEXITClick(Sender: TObject);
begin
ShouldStop := True;
Close;
end;
procedure TForm1.UpdateLabelActiveThreads;
begin
Dec(ActiveThreads);
LabelActiveThreads.Caption := IntToStr(ActiveThreads);
end;
procedure TForm1.UpdateLabelJobs(Sender: TObject);
begin
Dec(Form1.IdleJobs);
LabelIdle.Caption := IntToStr(IdleJobs);
end;
procedure TForm1.UpdateLabelFinished;
begin
Inc(Form1.JobsFinished);
LabelFinished.Caption := IntToStr(JobsFinished);
Gauge1.Progress := Gauge1.Progress + 1;
end;