Ich habe ein wenig nachgebessert. Kann jemand noch mal den Code anschauen?
Besser kriege ich es wohl nicht hin.

zusammenfalten · markieren

Delphi-Quellcode:

    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;

Du packst die Threads nach wie vor in Threads[Index] und greifst darauf nach dem Start der Threads (du erstellt diese ja nicht suspended, das ist der Parameter an Create) noch zu.

Erstens kann das wie gesagt knallen und zweitens wird das Timeout in Execute ggf. schon gelesen, bevor du es von außen setzt.

Du musst alle Werte im Konstruktor übergeben oder suspended starten.

Ok, also ist das Teil praktisch ...hmmm komplett falsch ?
Mit Timeout, nach deiner Erklärung kann ich nachvollziehen, daran habe ich leider nicht gedacht. Timeout kann ich irgendwie global setzen, oder eben in Create packen.
Das zu ändern, ist kein Problem.
Der Rest aber, findet doch erst statt wenn der Thread es meldet, also dürfte es nicht knallen. Sprich, die ganzen Rückmeldungen vom Thread kann ich so realisieren?
Ist das korrekt, oder liege ich wieder falsch? Ich wollte unbedingt den Zugriff vom Thread aus auf die Form1 vermeiden. Wie es am Anfang bemängelt wurde.

markieren

Delphi-Quellcode:

      Threads[Index].TimeOut := SpinEditTimeout.Value; // Das ist Müll. Wird korrigiert

      Threads[Index].OnUpdateActive := UpdateLabelActiveThreads;
      Threads[Index].OnUpdateJobs := UpdateLabelJobs;
      Threads[Index].OnUpdateFertig := UpdateLabelFinished;

Sorry fürs ständige Nachfragen, so lerne ich aber (für meine Verhältnisse) recht viel dazu.
Danke noch mal fürs Unterstützen.


EDIT:
Ich habe es doch so umgebaut

zusammenfalten · markieren

Delphi-Quellcode:

constructor TURLCheckerThread.Create(UrlList: TStrings; CSection1, CSection2: TCriticalSection; OnStatus: TProc<TstringList>; ShouldStop: PBoolean; OnUpdateActive, OnUpdateJobs, OnUpdateFertig: TNotifyEvent; Timeout: Word);
begin
  inherited Create(False);
  FUrlList := UrlList;
  FCSection1 := CSection1;
  FCSection2 := CSection2;
  FOnStatus := OnStatus;
  FShouldStop := ShouldStop;
  FreeOnTerminate := True;
  FTimeOut := Timeout;
  FUpdateAktiv := OnUpdateActive;
  FUpdateJobs := OnUpdateJobs;
  FUpdateFertig := OnUpdateFertig;
end;

und beim Start

zusammenfalten · markieren

Delphi-Quellcode:

procedure TForm1.ButtonStartClick(Sender: TObject);
var
  Threads : array[0..100] of TURLCheckerThread;
  Index : Integer;
  Timeout : Word;
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;

  LabelActiveThreads.Caption := '0';
  LabelJobs.Caption := '201';
  LabelIdle.Caption := '201';
  IdleJobs := 201;
  Gauge1.MaxValue := 201;
  Gauge1.Progress := 0;
  JobsFinished := 0;
  Timeout := SpinEditTimeout.Value * 1000;

  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, UpdateLabelActiveThreads, UpdateLabelJobs, UpdateLabelFinished, Timeout);

     {Zähle aktive Threads}
      Inc(ActiveThreads);
      LabelActiveThreads.Caption := IntToStr(ActiveThreads);
    end;
end;

Lass die Variable Threads : array[0..100] of TURLCheckerThread; einfach ganz weg.
Du darfst sie in deiner Konstellation doch ohnehin nach der Zuweisung nicht nutzen, also brauchst du sie nicht.

Ok, das habe ich irgendwo zum Thema ThreadPool gelesen, erschien mir wichtig zu sein.
Das habe ich so weit korrigiert. Array ist weg.
Kann man mit dem Rest irgendwie leben?
Es muss nicht die optimale Lösung sein, doch etwas Craschsicher sollte es schon sein.
Für mich ist eben auch wichtig, dass ich den Code selbst verstehe und nachvollziehen kann, wo, was passiert.

Hier noch mal die Übersicht. Zum Thema Monitor habe ich noch nichts gelesen, ich gehe davon aus, dass mein CS1 und CS2 es korrekt abfangen.

zusammenfalten · markieren

Delphi-Quellcode:

    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormCanResize(Sender: TObject; var NewWidth, NewHeight: Integer; var Resize: Boolean);
    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;
    FUpdateJobs : TNotifyEvent;
    FUpdateFertig : TNotifyEvent;
    FUrlList : TStrings;
    FCSection1 : TCriticalSection;
    FCSection2 : TCriticalSection;
    FOnStatus : TProc<TstringList>;
    FShouldStop : PBoolean;
    FTimeOut : Word;
  protected
    procedure Execute; override;
    procedure UpdateStatus(const Msg: TstringList);
  public
    constructor Create(UrlList: TStrings; CSection1, CSection2: TCriticalSection; OnStatus: TProc<TstringList>; ShouldStop: PBoolean; OnUpdateActive, OnUpdateJobs, OnUpdateFertig: TNotifyEvent; Timeout: Word);
  end;

{ TWorkerThread }
constructor TURLCheckerThread.Create(UrlList: TStrings; CSection1, CSection2: TCriticalSection; OnStatus: TProc<TstringList>; ShouldStop: PBoolean; OnUpdateActive, OnUpdateJobs, OnUpdateFertig: TNotifyEvent; Timeout: Word);
begin
  inherited Create(False);
  FUrlList := UrlList;
  FCSection1 := CSection1;
  FCSection2 := CSection2;
  FOnStatus := OnStatus;
  FShouldStop := ShouldStop;
  FreeOnTerminate := True;
  FTimeOut := Timeout;
  FUpdateAktiv := OnUpdateActive;
  FUpdateJobs := OnUpdateJobs;
  FUpdateFertig := OnUpdateFertig;
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;
  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; {Ich habe aber gelesen 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.FormCreate(Sender: TObject);
var
  Icon : TIcon;
begin
  Icon := TIcon.Create;
  Icon.Handle := LoadIcon(hInstance, 'ICON_1');
  Form1.Icon := Icon;
  Icon.Free;
end;

procedure TForm1.FormShow(Sender: TObject);
var
  R : TRect;
begin
  Statusbar1.Perform($040A, 1, Integer(@R));
  Gauge1.Parent := Statusbar1;
  Gauge1.Top := r.Top + 2;
  Gauge1.Left := r.Left + 2;
  Gauge1.Width := r.Right - r.Left - 4;
  Gauge1.Height := r.Bottom - r.Top - 4;
end;

procedure TForm1.FormCanResize(Sender: TObject; var NewWidth, NewHeight: Integer; var Resize: Boolean);
begin
  FormShow(Sender); {Wiederverwenden der Logik, weil es genauso wie in TForm1.FormShow ist}
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeAndNil(ErgebnisListe);
  FreeAndNil(UrlList);
  FreeAndNil(CSection1);
  FreeAndNil(CSection2);
end;

procedure TForm1.ButtonStartClick(Sender: TObject);
var
  Threads : TURLCheckerThread;
  Index : Integer;
  Timeout : Word;
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;

  LabelActiveThreads.Caption := '0';
  LabelJobs.Caption := '201';
  LabelIdle.Caption := '201';
  IdleJobs := 201;
  Gauge1.MaxValue := 201;
  Gauge1.Progress := 0;
  JobsFinished := 0;
  Timeout := SpinEditTimeout.Value * 1000;

  for Index := 1 to SpinEditThreads.Value do
    begin
      Threads := TURLCheckerThread.Create(UrlList, CSection1, CSection2,
        procedure(Msg: TstringList)
          var
            ErgebnisListe : TStringList;
          begin
            RichEditLog.Lines.Add(Msg.Text); {Ergebnis vom Thread als StringList}
          end, @ShouldStop, UpdateLabelActiveThreads, UpdateLabelJobs, UpdateLabelFinished, Timeout);

     {Zähle aktive Threads}
      Inc(ActiveThreads);
      LabelActiveThreads.Caption := IntToStr(ActiveThreads);
    end;
end;

procedure TForm1.ButtonWeiterClick(Sender: TObject);
var
  Threads : TURLCheckerThread;
  Index : Integer;
  Timeout : Word;
begin
  ShouldStop := False;
  Timeout := SpinEditTimeout.Value * 1000;

  for Index := 1 to SpinEditThreads.Value do
    begin
      Threads := TURLCheckerThread.Create(UrlList, CSection1, CSection2,
        procedure(Msg: TstringList)
          begin
            RichEditLog.Lines.Add(Msg.Text); {Ergebnis vom Thread als StringList}
          end, @ShouldStop, UpdateLabelActiveThreads, UpdateLabelJobs, UpdateLabelFinished, Timeout);

     {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;