unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, ComCtrls, ExtCtrls, StdCtrls;
type
TTestThread = class(TThread)
private
FInfo: string;
FMax: Integer;
FProgress: Integer;
FCriticalSection: TRTLCriticalSection;
protected
procedure Execute; override;
public
constructor Create(AMax: Integer; ACriticalSection: TRTLCriticalSection);
property Progress: Integer read FProgress;
property Info: string read FInfo;
end;
TForm1 = class(TForm)
Label1: TLabel;
ProgressBar1: TProgressBar;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
FCriticalSection: TRTLCriticalSection;
FThread: TTestThread;
procedure ThreadTerminated(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
constructor TTestThread.Create(AMax: Integer; ACriticalSection: TRTLCriticalSection);
begin
inherited Create(True);
FMax := AMax;
FCriticalSection := ACriticalSection;
end;
procedure TTestThread.Execute;
begin
while not Terminated and (FProgress <= FMax) do
begin
SpinWait(7000); // Hide some real work
if TryEnterCriticalsection(FCriticalSection) <> 0 then
try
Inc(FProgress);
FmtStr(FInfo, 'Pos: %d, Total: %.1f%%', [FProgress, FProgress * 100/ FMax]);
finally
LeaveCriticalsection(FCriticalSection);
end;
end;
end;
procedure TForm1.ThreadTerminated(Sender: TObject);
begin
FThread := nil;
ProgressBar1.Position := ProgressBar1.Max;
Label1.Caption := 'Complete!';
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
LPosition: Integer;
LCaption: string;
begin
if Assigned(FThread) then
begin
EnterCriticalsection(FCriticalSection);
try
LPosition := FThread.Progress;
LCaption := FThread.Info;
finally
LeaveCriticalsection(FCriticalSection);
end;
ProgressBar1.Position := LPosition;
Label1.Caption := LCaption;
end
else
Timer1.Enabled := False;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ProgressBar1.Max := 200000;
Timer1.Interval := 200;
InitCriticalSection(FCriticalSection);
FThread := TTestThread.Create(ProgressBar1.Max, FCriticalSection);
FThread.FreeOnTerminate := True;
FThread.OnTerminate := @ThreadTerminated;
FThread.Start;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if Assigned(FThread) then
FThread.OnTerminate := nil;
FThread.Free;
DoneCriticalsection(FCriticalSection);
end;
end.