?
Solved

Delphi Limiting Threads running at the same time.

Posted on 2007-08-01
7
Medium Priority
?
1,663 Views
Last Modified: 2013-11-23
Can someone modify me this code to limit threads runing at the same time. It is ok when it is a few urls in the list but when it will be 100-200 I think it would be a problem. So I need code that will limit number of thread running at the same time.


Thank you.

Unit1.dfm
=======

object Form1: TForm1
  Left = 121
  Top = 189
  Width = 544
  Height = 375
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object ListBox1: TListBox
    Left = 280
    Top = 16
    Width = 225
    Height = 137
    ItemHeight = 13
    Items.Strings = (
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.yahoo.co.in/')
    TabOrder = 0
  end
  object ListView1: TListView
    Left = 8
    Top = 8
    Width = 250
    Height = 201
    Columns = <
      item
      end
      item
        Width = 100
      end>
    TabOrder = 1
    ViewStyle = vsReport
  end
  object Button1: TButton
    Left = 56
    Top = 248
    Width = 153
    Height = 33
    Caption = 'Button1'
    TabOrder = 2
    OnClick = Button1Click
  end
end

Unit1.pas
=========

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdHTTP, StdCtrls, ComCtrls;

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    ListView1: TListView;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type
  TThreadForm1     =  class(TThread)
  private
     // Private declarations
     FForm:         TForm1;
     IdHTTP1:  TIdHTTP;
     FItemIndex:Integer;
     FUrl:String;
     Fgoogledata:String;
  protected
     // Protected declarations
     procedure      AfterSend;
     procedure      BeforeSend;
     procedure      Execute; override;
  public
     // Public declarations
     function       GetGoogleData(URL : string) : string;
     constructor    Create(Form: TForm1;ItemIndex:Integer;Url:String);
     procedure Main;
  end;


var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var i:Integer;
begin
  for i:=0 to ListBox1.Count-1 do
  begin
     ListView1.Items.Add.Caption := ListBox1.Items.Strings[i];
     TThreadForm1.Create(Self,i,ListBox1.Items.Strings[i]);
  end;
end;

procedure TThreadForm1.Main;
begin
  FForm.ListView1.Items.Item[FItemIndex].SubItems.Add(Fgoogledata);
end;


constructor TThreadForm1.Create(Form: TForm1;ItemIndex:Integer;Url:String);
begin
  // Set parameters
  FForm:=Form;
  FItemIndex:=ItemIndex;
  FUrl:=Url;
  // Perform inherited (don't suspend)
  inherited Create(False);
  // Set thread props
  FreeOnTerminate:=True;
  Priority:=tpLower;
end;

procedure TThreadForm1.BeforeSend;
begin
  IdHTTP1 := TIdHTTP.Create(nil);
end;

procedure TThreadForm1.AfterSend;
begin

end;

procedure TThreadForm1.Execute;
begin
  // ---- Set IdHTTP2 settings ---- //

     try
        BeforeSend;
        Fgoogledata:=GetGoogleData(FUrl);
        Synchronize(Main);
        AfterSend;
     finally
        IdHTTP1.Free;
     end;

end;




function TThreadForm1.GetGoogleData(URL : string) : string;
var
   GoogleResponse: TStringList;
begin
  try
   GoogleResponse := TStringList.Create;
   IdHTTP1.HandleRedirects := true;
   GoogleResponse.Text := IdHTTP1.Get(URL);
   result := GoogleResponse.Text;
  finally
   GoogleResponse.Free;
  end;

end;

end.
0
Comment
Question by:triz99
  • 3
  • 2
  • 2
7 Comments
 
LVL 26

Expert Comment

by:Russell Libby
ID: 19611936

I followed your other q, as an alternative, you might want to consider using the code below. The component does async downloading of URL's, allows request to be cancelled, and lets your app be responsive without worrying about threading issues or worker pool limiting.

Just a thought
Russell

-----
Source then dfm

unit Unit1;

interface

// UrlDown can be obtained from my site @
//
//   http://users.adelphia.net/~rllibby/downloads/urldown.zip
//
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, UrlDown;

type
  TForm1            =  class(TForm)
     UrlDownload1:  TUrlDownload;
     ListView1:     TListView;
     Button1:       TButton;
     ListBox1:      TListBox;
     procedure      Button1Click(Sender: TObject);
     procedure      UrlDownload1UrlOpen(Sender: TObject; ID: Cardinal);
     procedure      UrlDownload1UrlError(Sender: TObject; ID, Error: Cardinal);
     procedure      UrlDownload1UrlComplete(Sender: TObject; ID, TotalMilliseconds: Cardinal; Stream: TStream);
  private
     // Private declarations
  public
     // Public declarations
  end;

var
  Form1:            TForm1;

implementation
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var  liItem:        TListItem;
     dwIndex:       Integer;
begin

  // Walk all url's
  for dwIndex:=0 to Pred(Listbox1.Items.Count) do
  begin
     // Add list item
     liItem:=ListView1.Items.Add;
     // Set list item caption
     liItem.Caption:=Listbox1.Items[dwIndex];
     // Set subitem
     liItem.SubItems.Add('contacting server...');
     // Queue the request
     URLDownload1.OpenRequestEx(Listbox1.Items[dwIndex], nil, Pointer(liItem.Index));
  end;

end;

procedure TForm1.UrlDownload1UrlOpen(Sender: TObject; ID: Cardinal);
var  liItem:        TListItem;
begin

  // Get index from context pointer
  liItem:=ListView1.Items[Integer(URLDownload1.RequestContext[ID])];

  // Set subitems text
  liItem.SubItems[0]:='downloading contents...';

end;

procedure TForm1.UrlDownload1UrlError(Sender: TObject; ID, Error: Cardinal);
var  liItem:        TListItem;
begin

  // Get index from context pointer
  liItem:=ListView1.Items[Integer(URLDownload1.RequestContext[ID])];

  // Set subitems text
  liItem.SubItems[0]:=Format('failed to get URL data, error code (%d)', [Error]);

end;

procedure TForm1.UrlDownload1UrlComplete(Sender: TObject; ID, TotalMilliseconds: Cardinal; Stream: TStream);
var  liItem:        TListItem;
     strmString:    TStringStream;
begin

  // Get index from context pointer
  liItem:=ListView1.Items[Integer(URLDownload1.RequestContext[ID])];

  // Create string stream
  strmString:=TStringStream.Create(EmptyStr);

  // Resource protection
  try
     // Load from data stream
     strmString.CopyFrom(Stream, 0);
     // Set subitems text
     liItem.SubItems[0]:=strmString.DataString;
  finally
     // Free the string stream
     strmString.Free;
  end;

end;

end.

-- dfm --
object Form1: TForm1
  Left = 246
  Top = 238
  Width = 779
  Height = 479
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = ANSI_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object ListView1: TListView
    Left = 212
    Top = 44
    Width = 545
    Height = 385
    Columns = <
      item
        Caption = 'URL'
        Width = 120
      end
      item
        Caption = 'Result'
        Width = 200
      end>
    TabOrder = 0
    ViewStyle = vsReport
  end
  object Button1: TButton
    Left = 8
    Top = 12
    Width = 75
    Height = 25
    Caption = 'Button1'
    TabOrder = 1
    OnClick = Button1Click
  end
  object ListBox1: TListBox
    Left = 8
    Top = 44
    Width = 197
    Height = 385
    ItemHeight = 13
    Items.Strings = (
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.yahoo.co.in/')
    TabOrder = 2
  end
  object UrlDownload1: TUrlDownload
    OnUrlOpen = UrlDownload1UrlOpen
    OnUrlError = UrlDownload1UrlError
    OnUrlComplete = UrlDownload1UrlComplete
    UserAgent = 'TUrlDownload'
    Left = 156
    Top = 8
  end
end
0
 

Author Comment

by:triz99
ID: 19612174
Thank you for your trouble but this solution is not good for me :( sorry
0
 
LVL 26

Expert Comment

by:Russell Libby
ID: 19612231
Funny, as it does exactly the same thing as your doing now.

Best of luck
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.

 
LVL 10

Expert Comment

by:dinilud
ID: 19615283
i think rllibby's solution is OK for you.
0
 

Author Comment

by:triz99
ID: 19615510
It would be ok that I don't need to use IdHTTP for some other things. This code I have post is only PoC.
0
 
LVL 10

Accepted Solution

by:
dinilud earned 2000 total points
ID: 19615810
Unit1.dfm
=======

object Form1: TForm1
  Left = 51
  Top = 154
  Width = 674
  Height = 418
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnClose = FormClose
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object ListBox1: TListBox
    Left = 8
    Top = 8
    Width = 225
    Height = 137
    ItemHeight = 13
    Items.Strings = (
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.yahoo.co.in/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.yahoo.co.in/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.yahoo.co.in/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.yahoo.co.in/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.google.co.in/'
      'http://www.experts-exchange.com/'
      'http://www.yahoo.co.in/')
    TabOrder = 0
  end
  object ListView1: TListView
    Left = 8
    Top = 152
    Width = 649
    Height = 201
    Columns = <
      item
        Caption = 'Path'
        Width = 200
      end
      item
        Caption = 'Data'
        Width = 300
      end>
    TabOrder = 1
    ViewStyle = vsReport
  end
  object Button1: TButton
    Left = 280
    Top = 48
    Width = 153
    Height = 33
    Caption = 'Start'
    TabOrder = 2
    OnClick = Button1Click
  end
end


Unit1.pas
=======

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdHTTP, StdCtrls, ComCtrls;

type

  TStatus=(stPause,stRunning);

  TForm1 = class(TForm)
    ListBox1: TListBox;
    ListView1: TListView;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
    FRunningThreadCount:Integer;
    FThreadList:TList;
    function AddThread(TreeIndex:Integer;Url:String):TStatus;
    function InsertThread(Index,TreeIndex:Integer;Url:String):TStatus;
    procedure TerminateThread(Sender: TObject);
    procedure ExecuteStartNext;
  public
    { Public declarations }
  end;

type

  TThreadForm1     =  class(TThread)
  private
     // Private declarations
     FForm:         TForm1;
     IdHTTP1:  TIdHTTP;
     FUrl:String;
     Fgoogledata:String;
  protected
     // Protected declarations
     procedure      AfterSend;
     procedure      BeforeSend;
     procedure      Execute; override;
  public
     FItemIndex:Integer;
     FStatus:TStatus;
     // Public declarations
     function GetGoogleData(URL : string) : string;
     constructor Create(Form: TForm1;ItemIndex:Integer;Url:String;Status:TStatus);
     procedure Main;
     procedure Continue;
     procedure Pause;
  end;


var
  Form1: TForm1;

Const MaxThreadCount=5;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var i:Integer;
begin
  for i:=0 to ListBox1.Count-1 do
  begin
     ListView1.Items.Add.Caption := ListBox1.Items.Strings[i];
     AddThread(i,ListBox1.Items.Strings[i]);
  end;
end;

procedure TThreadForm1.Main;
begin
  FForm.ListView1.Items.Item[FItemIndex].SubItems.Add(Fgoogledata);
end;

procedure TThreadForm1.Continue;
begin
  Resume;
  FStatus:=stRunning;
end;

procedure TThreadForm1.Pause;
begin
  Suspend;
  FStatus:=stPause;
end;


constructor TThreadForm1.Create(Form: TForm1;ItemIndex:Integer;Url:String;Status:TStatus);
begin
  // Set parameters
  FForm:=Form;
  FItemIndex:=ItemIndex;
  FUrl:=Url;
  // Perform inherited (don't suspend)
  FStatus:=Status;
  inherited Create(FStatus=stPause);
  // Set thread props
  FreeOnTerminate:=True;
  Priority:=tpLower;
  OnTerminate:=Form.TerminateThread;
end;

procedure TThreadForm1.BeforeSend;
begin
  IdHTTP1 := TIdHTTP.Create(nil);
end;

procedure TThreadForm1.AfterSend;
begin

end;

procedure TThreadForm1.Execute;
begin
  // ---- Set IdHTTP2 settings ---- //

     try
        BeforeSend;
        Fgoogledata:=GetGoogleData(FUrl);
        Synchronize(Main);
        AfterSend;
     finally
        IdHTTP1.Free;
     end;

end;




function TThreadForm1.GetGoogleData(URL : string) : string;
var
   GoogleResponse: TStringList;
begin
  try
   GoogleResponse := TStringList.Create;
   IdHTTP1.HandleRedirects := true;
   GoogleResponse.Text := IdHTTP1.Get(URL);
   result := GoogleResponse.Text;
  finally
   GoogleResponse.Free;
  end;

end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FThreadList:=TList.Create;
  FRunningThreadCount:=0;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FThreadList.Free;
end;

function TForm1.AddThread(TreeIndex:Integer;Url:String):TStatus;
begin
  if FRunningThreadCount<MaxThreadCount then
  begin
    Result:=stRunning;
    inc(FRunningThreadCount);
  end else Result:=stPause;
  FThreadList.Add(TThreadForm1.Create(Self,TreeIndex,Url,Result));
end;

function TForm1.InsertThread(Index,TreeIndex:Integer;Url:String):TStatus;
begin
  if FRunningThreadCount<MaxThreadCount then
  begin
    Result:=stRunning;
    inc(FRunningThreadCount);
  end else Result:=stPause;
  FThreadList.Insert(Index,TThreadForm1.Create(Self,TreeIndex,Url,Result));
end;

procedure TForm1.TerminateThread(Sender: TObject);
begin
  FThreadList.Delete(FThreadList.IndexOf(TThreadForm1(Sender)));
  Dec(FRunningThreadCount);
  ExecuteStartNext;
end;

procedure TForm1.ExecuteStartNext;
var i:Integer;
begin
   i:=0;
   while i<FThreadList.Count do
   begin
      if TThreadForm1(FThreadList.Items[i]).FStatus=stPause then
      begin
         if FRunningThreadCount<MaxThreadCount then
         begin
           inc(FRunningThreadCount);
           TThreadForm1(FThreadList.Items[i]).Continue;
         end;
         Break;
      end;
      inc(i);
   end;
end;

end.
0
 

Author Comment

by:triz99
ID: 19635627
It works excellent. Thank you.
0

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

Question has a verified solution.

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

Hello everybody This Article will show you how to validate number with TEdit control, What's the TEdit control? TEdit is a standard Windows edit control on a form, it allows to user to write, read and copy/paste single line of text. Usua…
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 video summaries big data hadoop online training demo (http://onlineitguru.com/big-data-hadoop-online-training-placement.html) , and covers basics in big data hadoop .
When cloud platforms entered the scene, users and companies jumped on board to take advantage of the many benefits, like the ability to work and connect with company information from various locations. What many didn't foresee was the increased risk…

839 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