• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 754
  • Last Modified:

create and release a progressbar in thread

Hi,
 i have tried a few times but keep getting a error on removing the progressbar
The finished thing i want to end up with is a listbox with files, a button to start the threads off and the progress for each thread.
Also how to set the max amount of threads and make sure there released fully when done.
So for each thread on start, create the progress and caption and add it to the Listview window.
Then when the thread finishes, free the progressbar and caption and move others up.
All the code is here, but i cannot work out how to delete the progress when the thread finishes.
I am new to threads so excuse the messy code.
Anway, drop a listview with 2 coloums n report view. 2 buttons, and a listbox and memo on a form...

If soone can help with this i would be very greatful :)


unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtActns, ComCtrls, ActiveX, ExtCtrls;
 
type
  TDownloadThread = class(TThread)
  private
    FURL: string;
    FLocal: string;
    FList: TListView;
    FListItem: TListItem;
    pbRect: TRect;
    FProgressBar: TProgressbar;
    FProgressbarIndex: integer;
    FProgressbarIndexName: string;
  protected
    procedure Execute; override;
    procedure URLOnDownloadProgress(Sender: TDownLoadURL; Progress, ProgressMax: Cardinal; StatusCode: TURLDownloadStatus; StatusText: string; var Cancel: Boolean);
    procedure RunThread(const AUrl, sLocal: string; FProgressbarIndex: integer; FList: TListView);
  public
    constructor Create(const AUrl, sLocal: string; FList: Tlistview); reintroduce; overload;
    destructor Destroy; override;
  end;
 
type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button2: TButton;
    ListBox1: TListBox;
    ListView1: TListView;
    Button1: TButton;
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    procedure DownloadFile(url, local: string);
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
  DownloadThread: TDownloadThread;
 
implementation
 
{$R *.dfm}
 
destructor TDownloadThread.Destroy;
begin
  try
   // inherited Destroy;
  finally
 
  end;
end;
 
 
function RemoveBackSlash(const DirName: string): string;
begin
  Result := DirName;
  if (Length(Result) > 1) and
{$IFDEF CLR}
  (Result[Length(Result)] = '/')
{$ELSE}
  (AnsiLastChar(Result)^ = '/')
{$ENDIF CLR}
  then
    if not ((Length(Result) = 3) and (UpCase(Result[1]) in ['A'..'Z']) and
      (Result[2] = ':')) then
      Delete(Result, Length(Result), 1);
end;
 
function BreakPath(PathName: string): string;
var
  I: Integer;
begin
  PathName := RemoveBackSlash(PathName);
  while Pos('/', PathName) > 0 do
  begin
    i := Pos('/', PathName);
    Delete(PathName, 1, I);
  end;
  Result := PathName;
end;
 
 
procedure TDownloadThread.URLOnDownloadProgress;
var
  i: integer;
begin
  for I := 0 to form1.Listview1.items.Count - 1 do
  begin
    if FList.Items[I].Caption = FProgressbarIndexName then
      FProgressbarIndex := I;
  end;
  FProgressBar := TProgressBar(FList.Items[FProgressbarIndex].Data);
  FProgressBar.Max := ProgressMax;
  FProgressBar.Position := Progress;
end;
 
 
procedure TForm1.Button1Click(Sender: TObject);
var
  FList: TListView;
  FListItem: TListItem;
  i, idx: integer;
  pb: TProgressBar;
begin
  FList := ListView1;
  FListItem := FList.Selected;
  if FListItem <> nil then // if a items selected, remove it
  begin
    idx := FListItem.Index;
    TProgressBar(FListItem.Data).Free;
    FList.Items.Delete(idx);
    //move bars up
    for i := idx to -1 + FList.Items.Count do
    begin
      FListItem := FList.Items.Item[i];
      pb := TProgressBar(FListItem.Data);
      pb.Top := pb.Top -
        (pb.BoundsRect.Bottom -
        pb.BoundsRect.Top);
    end;
  end;
 
end; //RemoveItemButtonClick
 
procedure TForm1.Button2Click(Sender: TObject);
var
  I: integer;
begin
  for I := 0 to Listbox1.items.Count - 1 do
  begin
    downloadfile(listbox1.Items.Strings[i], 'd:\' + BreakPath(listbox1.Items.Strings[i]));
  end;
end;
 
constructor TDownloadThread.Create(const AUrl, sLocal: string; FList: TListview);
begin
  inherited Create(False);
  Downloadthread.FURL := AURL;
  DownloadThread.FLocal := sLocal;
  DownloadThread.FList := FList;
  DownloadThread.FProgressBar := fprogressbar;
end;
 
procedure TDownloadThread.RunThread(const AUrl, sLocal: string; FProgressbarIndex: integer; FList: TListview);
var
  DownloadThread: TDownloadThread;
const
  pbColumnIndex = 1;
  pbMax = 100;
begin
  CoInitializeEx(nil, COINIT_MULTITHREADED);
  DownloadThread := TDownloadThread.Create(true);
  DownloadThread.FreeOnTerminate := true;
  DownloadThread.FURL := AURL;
  DownloadThread.FLocal := sLocal;
  DownloadThread.FList := FList;
  DownloadThread.FListItem := FList.Items.Add;
  DownloadThread.FListItem.Caption := extractfilename(slocal);
  DownloadThread.FProgressBar := TProgressBar.Create(nil); //create a ProgressBar, place it in the second column
  DownloadThread.FProgressBar.Parent := FList;
  DownloadThread.FListItem.Data := DownloadThread.FProgressBar;
  DownloadThread.pbRect := DownloadThread.FListItem.DisplayRect(drBounds);
  DownloadThread.pbRect.Left := DownloadThread.pbRect.Left +
    DownloadThread.FList.Columns[-1 + pbColumnIndex].Width;
  DownloadThread.pbRect.Right := DownloadThread.pbRect.Left +
    DownloadThread.FList.Columns[pbColumnIndex].Width;
  DownloadThread.FProgressBar.BoundsRect := DownloadThread.pbRect;
  // progressbar is created, we now need to give the thread the index number
  // FProgressbarIndex
  DownloadThread.FProgressbarIndexName := extractfilename(sLocal);
  DownloadThread.FProgressbarIndex := FProgressbarIndex;
 
  DownloadThread.Resume;
end;
 
 
procedure TDownloadThread.Execute;
begin
  with TDownloadURL.Create(nil) do
  try
    URL := FURL;
    FileName := FLocal;
    OnDownloadProgress := URLOnDownloadProgress;
    ExecuteTarget(nil);
  finally
    Free;
  end;
  form1.memo1.lines.add('Downloaded ' + FLocal);
end;
 
 
 
procedure TForm1.DownloadFile(url, local: string);
begin
  DownloadThread.RunThread(url, local, 0, listview1);
end;
 
 
end.

Open in new window

0
satmanuk
Asked:
satmanuk
  • 4
  • 2
1 Solution
 
dprochownikCommented:
Let start from thread and VCL basics:
VCL IS NOT multihreaded so creating, destroing and even changing properties of VCL forms/controls directly in thread is rather wrong idea.

If you realy want to do all of this in threads, you should encapsulate that in seperated procedures and call then using synchronize.
Synchronize will do all this stuff in  main application thread.

For example this is code for thread changing progressbar position:
Type
  TSampleThread = class(TThread)
  private
    FProgressBar: TProgressbar;
    Fposition: Integer;

    procedure SetPosition;
  public
    procedure Execute; override;
    ....
  end;
 
  procedure TSampleThread .SetPosition;
  begin
    fProgressBar.position := fposition;
  end;

  procedure TSampleThread .Execute;
  begin
    while not terminated do
    begin
      inc(fPosition);
      Synchronize(SetPosition);
    end;
  end;
 
Of course that part called in "Synchronize" is executed in main application thread, so tSampleThread has to wait until main thread can process synchronize section.
Thats why synchronize should by called as rarely as possible.

You should read more about threads and review yours code, because right now is definitely not safe.

Good luck :)

0
 
Geert GruwezOracle dbaCommented:
you are assuming that you need to create a progressbar inside a thread.
This is wrong !
Your thread doesn't need to know about any progressbar
What is does know, is how much it has downloaded of a file (x bytes out of total y bytes)
You should completely separate the funtionality of downloading
and the displaying of information on the screen.
Do not using any VCL components in a thread.

A listview is something very basic, it would be better to show the percentage of the file downloaded
in a text form

If you want something more advanced, go see a 3rd party component like Quantumgrid of DevExpress
This component can display a progressbar inside a grid

I altered your code and added my own Thread Type for progress of download:
TCallbackThread

when clicking the buttonDownLoad, it will add the selected files to a WaitingFiles buffer
This WaitingFiles is a TStringList with files waiting to be download
A Timer will check every 10 secs to see if the number of threads downloading is below 5
and start a download

You still have some work on this, but it should get you in the correct direction
if you really want progressbars, you'll have to create them on the form, and not in the thread !
If you need further assistance please ask

PS: I don't have TDownloadUrl code, so can't compile :)


unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls;
 
const
  MaxThreadsRunning = 5;
 
type
  TCallbackProc = procedure (aMessage: string; aProgress: Integer; aMessageInfo: Integer = 0) of object;
 
  TCallbackThread = class(TThread)
  private
    FCallBack: TCallbackProc;
    FCallbackMsg: string;
    FCallbackMsgInfo: integer;
    FCallbackProgress: Integer; // 0..100
    procedure SynchedCallback;
  protected
    procedure DoCallback(aMsg: string; aProgress: Integer; aMsgInfo: integer = 0); virtual;
    property Callback: TCallbackProc read FCallback;
  public
    constructor Create(aCallback: TCallbackProc; CreateSuspended: Boolean = False); reintroduce; virtual;
  end;
 
  TDownloadThread = class(TThread)
  private
    FURL: string;
    FLocal: string;
    FDownloadId: integer;
  protected
    procedure Execute; override;
    procedure URLOnDownloadProgress(Sender: TDownLoadURL; Progress, ProgressMax: Cardinal; StatusCode: TURLDownloadStatus; StatusText: string; var Cancel: Boolean);
    procedure RunThread(const AUrl, sLocal: string);
  public
    constructor Create(const AUrl, sLocal: string; aDownloadId: Integer; aCallback: TCallbackProc); reintroduce; overload;
    destructor Destroy; override;
  end;
 
  TForm1 = class(TForm)
    ListBoxAvailableFiles: TListBox;
    ListView1: TListView;
    ButtonDownload: TButton;
    Timer1: TTimer;
    procedure ButtonDownloadClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    fWaitingFiles: TStrings;
    fThreadsRunning: Integer;
    fLastDownLoadThreadId: Integer;
    procedure DownloadCallbackProgress(aMessage: string; aProgress: Integer; aMessageInfo: Integer = 0);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
function RemoveBackSlash(const DirName: string): string;
begin
  Result := DirName;
  if (Length(Result) > 1) and
{$IFDEF CLR}
  (Result[Length(Result)] = '/')
{$ELSE}
  (AnsiLastChar(Result)^ = '/')
{$ENDIF CLR}
  then
    if not ((Length(Result) = 3) and (UpCase(Result[1]) in ['A'..'Z']) and
      (Result[2] = ':')) then
      Delete(Result, Length(Result), 1);
end;
 
function BreakPath(PathName: string): string;
var
  I: Integer;
begin
  PathName := RemoveBackSlash(PathName);
  while Pos('/', PathName) > 0 do
  begin
    i := Pos('/', PathName);
    Delete(PathName, 1, I);
  end;
  Result := PathName;
end;
 
{ TCallbackThread }
 
constructor TCallbackThread.Create(aCallback: TCallbackProc; CreateSuspended: Boolean = False);
begin
  inherited Create(CreateSuspended);
  FreeOnTerminate := True;
  FCallback := aCallback;
end;
 
procedure TCallbackThread.DoCallback(aMsg: string; aProgress: Integer; aMsgInfo: Integer = 0);
begin
  FCallbackMsg := aMsg;
  FCallbackProgress := aProgress;
  FCallbackMsgInfo := aMsgInfo;
  Synchronize(SynchedCallback);
end;
 
procedure TCallbackThread.SynchedCallback;
begin
  if Assigned(FCallback) then
    FCallBack(FCallbackMsg, FCallbackProgress, FCallbackMsgInfo);
end;
 
{ TDownloadThread }
 
constructor TDownloadThread.Create(const aUrl, sLocal: string; aDownloadId: Integer; aCallback: TCallbackProc);
begin
  inherited Create(aCallback);
  FURL := aURL;
  FLocal := sLocal;
  fDownloadId := aDownloadId;
end;
 
procedure TDownloadThread.Execute;
var aDownLoadUrl: TDownLoadUrl;
begin
  DoCallback('START', 0, fDownLoadId);
  try
    aDownLoadUrl := TDownloadURL.Create(nil);
    try
      aDownLoadUrl.URL := FURL;
      aDownLoadUrl.FileName := FLocal;
      aDownLoadUrl.OnDownloadProgress := URLOnDownloadProgress;
      aDownLoadUrl.ExecuteTarget(nil);
    finally
      FreeAndNil(aDownLoadUrl);
    end;
  finally
    DoCallback('END', 0, fDownLoadId);
  end;
end;
 
procedure TDownloadThread.URLOnDownloadProgress;
var ProgressProcent: Cardinal;
begin
  ProgressProcent := 0;
  if ProgressMax > 0 then
    ProgressProcent := Round(Progress / ProgressMax);
  DoCallback('Progress', ProgressProcent, fDownLoadId);
end;
 
{ TForm1 }
 
constructor TForm1.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fWaitingFiles := TStringList.Create;
  fThreadsRunning := 0;
  fLastDownLoadThreadId := 0;
end;
 
destructor TForm1.Destroy;
begin
  FreeAndNil(fWaitingFiles);
  inherited Destroy;
end;
 
procedure TForm1.ButtonDownloadClick(Sender: TObject);
var I: Integer;
begin
  ListBoxAvailableFiles.Items.BeginUpdate;
  try
    for I := 0 to ListBoxAvailableFiles.Count-1 do
      if Copy(ListBoxAvailableFiles.Items[I], 1, 1) <> '~' then
        if ListBoxAvailableFiles.Selected[I] then
        begin
          fWaitingFiles.Add(ListBoxAvailableFiles.Items[I]);
          ListBoxAvailableFiles.Items[I] := '~' + ListBoxAvailableFiles.Items[I];
        end;
  finally
    ListBoxAvailableFiles.Items.EndUpdate;
  end;
end;
 
procedure TForm1.Timer1Timer(Sender: TObject);
var aUrl, aDestFile: string;
  li: TListItem;
begin
  if (fThreadsRunning < MaxThreadsRunning) and (fWaitingFiles.Count > 0) then
  begin
    Inc(fLastDownLoadThreadId);
    aUrl := fWaitingFiles[0];
    aDestFile := 'D:\' + BreakPath(aUrl);
    ListView1.Items.BeginUpdate;
    try
      li := ListView1.Items.Add(aUrl);
      li.Data := TObject(fLastDownLoadThreadId);
      li.SubItems.Add(aDestFile);
      li.SubItems.Add('0 %');
    finally
      ListView1.Items.EndUpdate;
    end;
    TDownloadThread.Create(aUrl, aDestFile, fLastDownLoadThreadId, DownloadCallbackProgress);
  end;
end;
 
procedure TForm1.DownloadCallbackProgress(aMessage: string; aProgress, aMessageInfo: Integer);
var I: Integer;
begin
  if aMessage = 'Start' then
    Inc(fThreadsRunning)
  else if aMessage = 'Progress' then
  begin
    ListView1.Items.BeginUpdate;
    try
      for I := 0 to ListView1.Items.Count-1 do
        if Integer(ListView1.Items[I].Data) = aMessageInfo then
        begin
          ListView1.Items[I].SubItems[1] := IntToStr(aProgress) + ' %';
          Break;
        end;
    finally
      ListView1.Items.EndUpdate;
    end;
  end else if aMessage = 'End' then
    Dec(fThreadsRunning);
end;
 
end.

Open in new window

0
 
Geert GruwezOracle dbaCommented:
i forgot to delete the items in the WaitingFiles

added the line
fWaitingFiles.Delete(0);
procedure TForm1.Timer1Timer(Sender: TObject);
var aUrl, aDestFile: string;
  li: TListItem;
begin
  if (fThreadsRunning < MaxThreadsRunning) and (fWaitingFiles.Count > 0) then
  begin
    Inc(fLastDownLoadThreadId);
    aUrl := fWaitingFiles[0];
    aDestFile := 'D:\' + BreakPath(aUrl);
    ListView1.Items.BeginUpdate;
    try
      li := ListView1.Items.Add(aUrl);
      li.Data := TObject(fLastDownLoadThreadId);
      li.SubItems.Add(aDestFile);
      li.SubItems.Add('0 %');
    finally
      ListView1.Items.EndUpdate;
    end;
    TDownloadThread.Create(aUrl, aDestFile, fLastDownLoadThreadId, DownloadCallbackProgress);
    fWaitingFiles.Delete(0);
  end;
end;

Open in new window

0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
Geert GruwezOracle dbaCommented:
bug: match the case of 'START' and 'END'

procedure TDownloadThread.Execute;
var aDownLoadUrl: TDownLoadUrl;
begin
  DoCallback('Start', 0, fDownLoadId);
  try
    aDownLoadUrl := TDownloadURL.Create(nil);
    try
      aDownLoadUrl.URL := FURL;
      aDownLoadUrl.FileName := FLocal;
      aDownLoadUrl.OnDownloadProgress := URLOnDownloadProgress;
      aDownLoadUrl.ExecuteTarget(nil);
    finally
      FreeAndNil(aDownLoadUrl);
    end;
  finally
    DoCallback('End', 0, fDownLoadId);
  end;
end;
0
 
satmanukAuthor Commented:
i get the folling error
[DCC Error] Unit1.pas(122): E2035 Not enough actual parameters

on
  inherited Create(aCallback);
in TDownloadThread.Create


0
 
Geert GruwezOracle dbaCommented:
line 29 should be :

TDownloadThread = class(TCallbackThread)

0
 
satmanukAuthor Commented:
thanks, points given
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 4
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now