Solved

Showing progress from multiply threads

Posted on 2011-09-20
1
415 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
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

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

In this tutorial I will show you how to use the Windows Speech API in Delphi. I will only cover basic functions such as text to speech and controlling the speed of the speech. SAPI Installation First you need to install the SAPI type library, th…
Introduction I have seen many questions in this Delphi topic area where queries in threads are needed or suggested. I know bumped into a similar need. This article will address some of the concepts when dealing with a multithreaded delphi database…
This demo shows you how to set up the containerized NetScaler CPX with NetScaler Management and Analytics System in a non-routable Mesos/Marathon environment for use with Micro-Services applications.
This tutorial demonstrates a quick way of adding group price to multiple Magento products.

747 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

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now