Solved

Showing progress from multiply threads

Posted on 2011-09-20
1
428 Views
Last Modified: 2016-09-29
I opened this new discussion especially for Geert_Gruwez, about his article of:

http://www.experts-exchange.com/Programming/Languages/Pascal/Delphi/A_239-Displaying-progress-in-the-main-form-from-a-thread-in-Delphi.html#discussion

So, lets continue the talk here, as the admin stated we need to open a new topic about this instead of continueing it in the other one.

so, as you saw, i store each thread's personal handle to the TProgressBar in an array of TProgressBar.

how many progress bars are being created at run time ? that's the user choice, using SetLength on the array.

so you said something like:

"your form needs to know what thread is corresponding to what progressbar
what are you using to start the multiple threads ?
at the time you start the threads, i imagine you are creating just as many progressbars ?

ah here :
 with TFetchDataThread.Create(
      alabel[nLoop], apbar[nLoop], hOpenFile[nLoop], hInetFile[nLoop], i64Start, i64End ) do
      begin
        Priority := tpNormal;
        Start;
      end;

you basically pass the progressbar to the thread
but ... it would be better if you pass this variable to the routine in the callback
sample callback :"


type
  TProgressCallback = procedure (Sender: TObject; aProgress: TObject; aProcent: Integer);

and in your form:

procedure TFormxXXX.ThreadProgress(Sender: TObject; aProgress: TObject; aProcent: Integer);
begin
  // Assuming min = 0 and Max = 100
  TProgressBar(AProgress).Position := aProcent;
  TProgressBar(AProgress).Update;
end;

Open in new window

0
Comment
Question by:rotem156
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
1 Comment
 
LVL 21

Accepted Solution

by:
developmentguru earned 500 total points
ID: 36578184
For reasons of flexibility and ease of use I would make the event either a standard TNotifyEvent
procedure (Sender : TObject);

or, instead of TObject, a set TObject descendant that related to doing the update.

Sending the progress value alone works well for one thread.  If you are timing 3 things at the same time it would be good to know 1) which update you are getting and 2) be able to get more information from the update if necessary.

1) The thread could contain a Name or Tag field to identify it, or you could compare by using "if Sender is TTestSort1 then" type of test.  I might go so far as to allow a tag field and a name field to give the end user the flexibility to handle it how they want to.
2) Not all updates fit neatly into the 0-100 scheme.  While they can all be made to, many applications only show a good status using nested progress bars.  In this type of case it could be an update using 3 separate values.

I absolutely do NOT agree with sending along a copy of the object to be updated.  The coupling between the thread running the code and the progress bar updating the progress should be loose.  Neither should know about the other.

Here is a dual mode example I whipped up in Delphi XE.  The DFM and the PAS are included in the CODE section.  I threw this together in about an hour so I expect a bunch of comments.  It uses the standard progress bars which have some timing delays.  Some of the updates would be done a bit differently in a real life scenario (the update on the task progress bar would not show up until after completed).  I mention these things because what you see on the screen will not necessarily match the progress shown in text (on the complex test).  The point of all of this is to show the updates of the display happening from multiple threads.  The examples literally do nothing but display the mechanism.

The first example is timing 3 things at the same time.  I use an ActionList to enable and disable the buttons based on whether the associated threads are running.  That is the simpler of the two examples.  

The complex example does a tiered update showing the task being worked on, progress on the number of headers for each task and the progress on the line items for each header.  On top of that the display is updating labels to give the user more visual feedback.  All of this is from a hierarchy of classes that divide out some of the functionality as needed.

Let me know if there are any questions...
---DFM---
object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 108
  ClientWidth = 567
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 8
    Top = 9
    Width = 63
    Height = 13
    Caption = 'Speed Test 1'
  end
  object Label2: TLabel
    Left = 8
    Top = 32
    Width = 63
    Height = 13
    Caption = 'Speed Test 2'
  end
  object Label3: TLabel
    Left = 8
    Top = 55
    Width = 63
    Height = 13
    Caption = 'Speed Test 3'
  end
  object Label4: TLabel
    Left = 272
    Top = 9
    Width = 22
    Height = 13
    Caption = 'Task'
  end
  object Label5: TLabel
    Left = 272
    Top = 32
    Width = 35
    Height = 13
    Caption = 'Header'
  end
  object Label6: TLabel
    Left = 272
    Top = 55
    Width = 44
    Height = 13
    Caption = 'Line Item'
  end
  object lblTask: TLabel
    Left = 497
    Top = 8
    Width = 22
    Height = 13
    Caption = 'Task'
  end
  object lblHeader: TLabel
    Left = 497
    Top = 32
    Width = 35
    Height = 13
    Caption = 'Header'
  end
  object lblLineItem: TLabel
    Left = 497
    Top = 55
    Width = 44
    Height = 13
    Caption = 'Line Item'
  end
  object pgRaceOne: TProgressBar
    Left = 77
    Top = 8
    Width = 150
    Height = 17
    TabOrder = 0
  end
  object pgRaceTwo: TProgressBar
    Left = 77
    Top = 31
    Width = 150
    Height = 17
    TabOrder = 1
  end
  object pgRaceThree: TProgressBar
    Left = 77
    Top = 54
    Width = 150
    Height = 17
    TabOrder = 2
  end
  object pbTask: TProgressBar
    Left = 341
    Top = 8
    Width = 150
    Height = 17
    TabOrder = 3
  end
  object pbHeader: TProgressBar
    Left = 341
    Top = 31
    Width = 150
    Height = 17
    TabOrder = 4
  end
  object pbLineItem: TProgressBar
    Left = 341
    Top = 54
    Width = 150
    Height = 17
    TabOrder = 5
  end
  object btnRace: TButton
    Left = 96
    Top = 77
    Width = 75
    Height = 25
    Action = aRace
    TabOrder = 6
  end
  object btnComplex: TButton
    Left = 376
    Top = 77
    Width = 75
    Height = 25
    Action = aComplex
    TabOrder = 7
    OnClick = btnComplexClick
  end
  object ActionList1: TActionList
    OnUpdate = ActionList1Update
    Left = 240
    Top = 56
    object aRace: TAction
      Caption = 'Race'
      OnExecute = aRaceExecute
    end
    object aComplex: TAction
      Caption = 'Complex'
      OnUpdate = aComplexUpdate
    end
  end
end

---PAS---
unit frmMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ActnList;

type
  //generic base class to provide the SyncedProgress for all children
  TUpdateThread = class(TThread)
  private
    fProgressEvent : TNotifyEvent;
    fTag : integer;
    fName : string;
  protected
    {SyncProgress is a default procedure to call in oprder to trigger front end
     update. This should always be called as Synchronize(SyncedProgress) after
     having updated the properties that the front end will need to be able to
     see in order to update the display.  Defined in a base class for all
     descendants to use.}
    procedure SyncedProgress;
  public
    constructor Create(AProgressEvent : TNotifyEvent; CreateSuspended : boolean = true); reintroduce; virtual;

    property Tag : integer read fTag write fTag;
    property Name : string read fName write fName;
  end;

  //base class for all threads that will handle a percentage of progress
  //abstract class.  Descendants should provide the Execute method and set the
  //progress property when needed.
  TPercent = 0..100;
  TPercentCompleteThread = class(TUpdateThread)
  private
    fProgress : TPercent;
    procedure SetProgress(const Value: TPercent);
  protected
  public
    property Progress : TPercent read fProgress write SetProgress;
  end;

  //Actual test class for updating the first 3 progress bars.
  TRaceType = (rtOne, rtTwo, rtThree);
  TRaceThread = class(TPercentCompleteThread)
  private
    fDelay : integer;
  protected
  public
    constructor Create(AProgressEvent : TNotifyEvent; CreateSuspended : boolean = true); reintroduce; virtual;

    procedure Execute; override;
  end;

  TTask = (tParts, tSalesOrders, tShipments);
  TTaskHeaderLineItemThread = class(TUpdateThread)
  private
    fUpdateRanges : TNotifyEvent;

    fLastTask : integer;
    fLastHeader : integer;
    fLastLineItem : integer;

    fTask : integer;
    fTaskName : string;
    fHeader : integer;
    fLineItem : integer;

    procedure SetLastHeader(const Value: integer);
    procedure SetLastLineItem(const Value: integer);
    procedure SetLastTask(const Value: integer);
    procedure SetHeader(const Value: integer);
    procedure SetLineItem(const Value: integer);
    procedure SetTask(const Value: integer);
    function GetCurrentTask: TTask;
  protected
    procedure SyncedUpdateRanges;
    procedure UpdateTaskName;
  public
    procedure Execute; override;

    property UpdateRanges : TNotifyEvent read fUpdateRanges write fUpdateRanges;

    property LastTask : integer read fLastTask write SetLastTask;
    property LastHeader : integer read fLastHeader write SetLastHeader;
    property LastLineItem : integer read fLastLineItem write SetLastLineItem;

    property Task : integer read fTask write SetTask;
    property TaskName : string read fTaskName;
    property CurrentTask : TTask read GetCurrentTask;
    property Header : integer read fHeader write SetHeader;
    property LineItem : integer read fLineItem write SetLineItem;
  end;

  TForm1 = class(TForm)
    pgRaceOne: TProgressBar;
    pgRaceTwo: TProgressBar;
    pgRaceThree: TProgressBar;
    pbTask: TProgressBar;
    pbHeader: TProgressBar;
    pbLineItem: TProgressBar;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    btnRace: TButton;
    ActionList1: TActionList;
    aRace: TAction;
    lblTask: TLabel;
    lblHeader: TLabel;
    lblLineItem: TLabel;
    aComplex: TAction;
    btnComplex: TButton;
    procedure ActionList1Update(Action: TBasicAction; var Handled: Boolean);
    procedure aRaceExecute(Sender: TObject);
    procedure btnComplexClick(Sender: TObject);
    procedure aComplexUpdate(Sender: TObject);
  private
    { Private declarations }
    fRace1 : TRaceThread;
    fRace2 : TRaceThread;
    fRace3 : TRaceThread;
    fComplex : TTaskHeaderLineItemThread;
    procedure UpdateRaceProgress(Sender : TObject);
    procedure ContestantTerminated(Sender : TObject);

    procedure ComplexProgress(Sender : TObject);
    procedure ComplexRange(Sender : TObject);
    procedure ComplexTerminated(Sender : TObject);
  public
    { Public declarations }
  end;

const
  TaskNames : array[TTask] of String = ('Parts', 'Sales Orders', 'Shipments');

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TUpdateThread }

constructor TUpdateThread.Create(AProgressEvent: TNotifyEvent;
  CreateSuspended: boolean);
begin
  //call inherited with a true to start it as suspended... we don't want it to
  //be able to run until we have finished setting it up...
  inherited create(true);

  FreeOnTerminate := true;

  //set the progress event.  If it ran before this was set we could miss updates
  fProgressEvent := AProgressEvent;

  //If it was not supposed to be created suspended then start it.
  if not CreateSuspended then
    Start;
end;

procedure TUpdateThread.SyncedProgress;
begin
  if Assigned(fProgressEvent) then
    fProgressEvent(Self);
end;

{ TPercentCompleteThread }

procedure TPercentCompleteThread.SetProgress(const Value: TPercent);
begin
  if fProgress <> Value then
    begin
      fProgress := Value;
      Synchronize(SyncedProgress);
    end;
end;

{ TRaceThread }

constructor TRaceThread.Create(AProgressEvent: TNotifyEvent;
  CreateSuspended: boolean);
begin
  inherited;
  fDelay := Random(5);
end;

procedure TRaceThread.Execute;
var
  I : Integer;

begin
  inherited;
  for I := 0 to 100 do
    begin
      Sleep(fDelay * 100);
      Progress := I;
    end;
end;

procedure TForm1.aComplexUpdate(Sender: TObject);
begin
  btnComplex.Enabled := not Assigned(fComplex);
end;

procedure TForm1.ActionList1Update(Action: TBasicAction; var Handled: Boolean);
begin
  btnRace.Enabled := not (Assigned(fRace1) or Assigned(fRace2) or Assigned(fRace3));
end;

procedure TForm1.aRaceExecute(Sender: TObject);
begin
  fRace1 := TRaceThread.Create(UpdateRaceProgress);
  fRace1.Tag := ord(rtOne);
  fRace1.OnTerminate := ContestantTerminated;

  fRace2 := TRaceThread.Create(UpdateRaceProgress);
  fRace2.Tag := ord(rtTwo);
  fRace2.OnTerminate := ContestantTerminated;

  fRace3 := TRaceThread.Create(UpdateRaceProgress);
  fRace3.Tag := ord(rtThree);
  fRace3.OnTerminate := ContestantTerminated;

  fRace1.Start;
  fRace2.Start;
  fRace3.Start;
end;

procedure TForm1.btnComplexClick(Sender: TObject);
begin
  fComplex := TTaskHeaderLineItemThread.Create(ComplexProgress);
  fComplex.UpdateRanges := ComplexRange;
  fComplex.OnTerminate := ComplexTerminated;

  fComplex.Start;
end;

procedure TForm1.ComplexProgress(Sender: TObject);
var
  Complex : TTaskHeaderLineItemThread absolute Sender;

begin
  if Sender is TTaskHeaderLineItemThread then
    begin
      pbTask.Position := Complex.Task;
      lblTask.Caption := Complex.TaskName;

      pbHeader.Position := Complex.Header;
      lblHeader.Caption := IntToStr(Complex.Header) + '/' +
        IntToStr(Complex.LastHeader);

      pbLineItem.Position := Complex.LineItem;
      lblLineItem.Caption := IntToStr(Complex.LineItem) + '/' +
        IntToStr(Complex.LastLineItem);
    end;
end;

procedure TForm1.ComplexRange(Sender: TObject);
var
  Complex : TTaskHeaderLineItemThread absolute Sender;

begin
  if Sender is TTaskHeaderLineItemThread then
    begin
      pbTask.Max := Complex.LastTask;
      pbHeader.Max := Complex.LastHeader;
      pbLineItem.Max := Complex.LastLineItem;
    end;
end;

procedure TForm1.ComplexTerminated(Sender: TObject);
begin
  if Sender is TTaskHeaderLineItemThread then
    fComplex := nil;
end;

procedure TForm1.ContestantTerminated(Sender: TObject);
var
  Race : TRaceThread absolute Sender;

begin
  if Sender is TRaceThread then
    begin
      case TRaceType(Race.Tag) of
        rtOne : fRace1 := nil;
        rtTwo : fRace2 := nil;
        rtThree : fRace3 := nil;
      end;
    end;
end;

procedure TForm1.UpdateRaceProgress(Sender: TObject);
var
  Race : TRaceThread absolute Sender;

begin
  if Sender is TRaceThread then
    begin
      case TRaceType(Race.Tag) of
        rtOne : pgRaceOne.Position := Race.Progress;
        rtTwo : pgRaceTwo.Position := Race.Progress;
        rtThree : pgRaceThree.Position := Race.Progress;
      end;
    end;
end;

{ TTaskHeaderLineItemThread }

procedure TTaskHeaderLineItemThread.Execute;
//constants show 5 parts 10 sales orders and 30 shipments to process
//each with it's own line items
const
  TaskHeaders : array[TTask] of word = (5, 10, 30);

var
  T, Header, LineItem : integer;

begin
  inherited;

  //all of the on screen updates should only happen when all of the values have
  //had a chance to update.  this means setting all of the values quietly and
  //updating the status at the lowest level.

  //Each LAST property that is set automatically gives the front end a chance
  //to set the range

  LastTask := ord(High(TTask));
  for T := ord(Low(TTask)) to ord(High(TTask)) do
    begin
      fTask := T; //Update the private var
      UpdateTaskName;

      LastHeader := TaskHeaders[CurrentTask];
      for Header := 1 to LastHeader do
        begin
          fHeader := Header; //Update the private var

          LastLineItem := Random(10);
          for LineItem := 1 to LastLineItem do
            begin
              fLineItem := LineItem; //Update the private var
              Synchronize(SyncedUpdateRanges);

              sleep(100);
              Synchronize(SyncedProgress);
            end;
        end;
    end;
end;

function TTaskHeaderLineItemThread.GetCurrentTask: TTask;
begin
  result := TTask(fTask);
end;

procedure TTaskHeaderLineItemThread.SetHeader(const Value: integer);
begin
  if fHeader <> Value then
    begin
      fHeader := Value;
      Synchronize(SyncedProgress);
    end;
end;

procedure TTaskHeaderLineItemThread.SetLastHeader(const Value: integer);
begin
  if fLastHeader <> Value then
    begin
      fLastHeader := Value;
      Synchronize(SyncedUpdateRanges);
    end;
end;

procedure TTaskHeaderLineItemThread.SetLastLineItem(const Value: integer);
begin
  if fLastLineItem <> Value then
    begin
      fLastLineItem := Value;
      Synchronize(SyncedUpdateRanges);
    end;
end;

procedure TTaskHeaderLineItemThread.SetLastTask(const Value: integer);
begin
  if fLastTask <> Value then
    begin
      fLastTask := Value;
      Synchronize(SyncedUpdateRanges);
    end;
end;

procedure TTaskHeaderLineItemThread.SetLineItem(const Value: integer);
begin
  if fLineItem <> Value then
    begin
      fLineItem := Value;
      Synchronize(SyncedProgress);
    end;
end;

procedure TTaskHeaderLineItemThread.SetTask(const Value: integer);
begin
  if fTask <> Value then
    begin
      fTask := Value;
      UpdateTaskName;
      Synchronize(SyncedProgress);
    end;
end;

procedure TTaskHeaderLineItemThread.SyncedUpdateRanges;
begin
  if Assigned(fUpdateRanges) then
    fUpdateRanges(Self);
end;

procedure TTaskHeaderLineItemThread.UpdateTaskName;
begin
  fTaskName := TaskNames[CurrentTask];
end;

end.

Open in new window

0

Featured Post

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

A lot of questions regard threads in Delphi.   One of the more specific questions is how to show progress of the thread.   Updating a progressbar from inside a thread is a mistake. A solution to this would be to send a synchronized message to the…
Introduction Raise your hands if you were as upset with FireMonkey as I was when I discovered that there was no TListview.  I use TListView in almost all of my applications I've written, and I was not going to compromise by resorting to TStringGrid…
Attackers love to prey on accounts that have privileges. Reducing privileged accounts and protecting privileged accounts therefore is paramount. Users, groups, and service accounts need to be protected to help protect the entire Active Directory …

737 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question