ThreadControl.pas

   1 unit ThreadControl;
   2
   3 interface
   4
   5 uses
   6         SysUtils, Classes, Controls, Forms, IdHTTP, IdComponent,
   7         HTTPApp, GikoSystem, BoardGroup, ItemDownload;
   8
   9 type
  10         TThreadControl = class(TThread)
  11         private
  12                 FItemList: TThreadList;                                 // \83_\83E\83\93\83\8d\81[\83h\82·\82é\83A\83C\83e\83\80\82ð\8ai\94[\82·\82é\83\8a\83X\83g
  13                 FAbort: Boolean;                                                                // \92\86\92f\83t\83\89\83O
  14                 FThreadList: TList;                                                     // \8eÀ\8dÛ\82É\83_\83E\83\93\83\8d\81[\83h\82·\82é\83X\83\8c\83b\83h\83I\83u\83W\83F\83N\83g\82Ì\83\8a\83X\83g
  15                 FMaxThreadCount: Integer;                               // \8dÅ\91å\83X\83\8c\83b\83h\90\94
  16                 FOnWork: TGikoWorkEvent;
  17                 FOnWorkBegin: TGikoWorkBeginEvent;
  18                 FOnWorkEnd: TGikoWorkEndEvent;
  19                 FOnDownloadEnd: TDownloadEndEvent;
  20                 FOnDownloadMsg: TDownloadMsgEvent;
  21                 procedure WorkBegin(Sender: TObject; AWorkMode: TWorkMode; const AWorkCountMax: Integer; Number: Integer);
  22                 procedure WorkEnd(Sender: TObject; AWorkMode: TWorkMode; Number: Integer);
  23                 procedure Work(Sender: TObject; AWorkMode: TWorkMode; const AWorkCount: Integer; Number: Integer);
  24                 procedure DownloadEnd(Sender: TObject; Item: TDownloadItem);
  25                 procedure DownloadMsg(Sender: TObject; Item: TDownloadItem; Msg: string; Icon: TGikoMessageIcon);
  26                 procedure SetMaxThreadCount(Count: Integer);
  27         protected
  28                 procedure Execute; override;
  29         public
  30                 constructor Create(CreateSuspended: Boolean);
  31                 destructor Destroy; override;
  32                 procedure AddItem(Item: TDownloadItem);
  33                 function GetSuspendThread: TDownloadThread;
  34                 function GetActiveThreadCount: Integer;
  35                 procedure DownloadAbort;
  36                 property MaxThreadCount: Integer read FMaxThreadCount write SetMaxThreadCount;
  37                 property OnWork: TGikoWorkEvent read FOnWork write FOnWork;
  38                 property OnWorkBegin: TGikoWorkBeginEvent read FOnWorkBegin write FOnWorkBegin;
  39                 property OnWorkEnd: TGikoWorkEndEvent read FOnWorkEnd write FOnWorkEnd;
  40                 property OnDownloadEnd: TDownloadEndEvent read FOnDownloadEnd write FOnDownloadEnd;
  41                 property OnDownloadMsg: TDownloadMsgEvent read FOnDownloadMsg write FOnDownloadMsg;
  42         end;
  43
  44 implementation
  45
  46 constructor TThreadControl.Create(CreateSuspended: Boolean);
  47 begin
  48         inherited Create(CreateSuspended);
  49         FItemList := TThreadList.Create;
  50         FThreadList := TList.Create;
  51
  52         FAbort := False;
  53 end;
  54
  55 destructor TThreadControl.Destroy;
  56 var
  57         i: Integer;
  58 begin
  59         for i := 0 to FThreadList.Count - 1 do begin
  60                 TDownloadThread(FThreadList[i]).Free;
  61         end;
  62         FThreadList.Free;
  63         FItemList.Free;
  64         inherited;
  65 end;
  66
  67 procedure TThreadControl.AddItem(Item: TDownloadItem);
  68 begin
  69         FItemList.Add(Item);
  70 end;
  71
  72 procedure TThreadControl.Execute;
  73 var
  74         List: TList;
  75         i: Integer;
  76         FDownThread: TDownloadThread;
  77 begin
  78         while not Terminated do begin
  79                 Sleep(10);
  80                 List := FItemList.LockList;
  81                 try
  82                         if List.Count > 0 then begin
  83                                 FDownThread := GetSuspendThread;
  84                                 if FDownThread <> nil then begin
  85                                         FDownThread.Item := TDownloadItem(List.Items[0]);
  86                                         List.Delete(0);
  87                                         FDownThread.Resume;
  88                                 end;
  89                         end;
  90                 finally
  91                         FItemList.UnlockList;
  92                 end;
  93                 if FAbort then begin
  94                         for i := 0 to FThreadList.Count - 1 do begin
  95                                 if not TDownloadThread(FThreadList[i]).Suspended then
  96                                         TDownloadThread(FThreadList[i]).Abort;
  97                         end;
  98                         List := FItemList.LockList;
  99                         try
 100                                 List.Clear;
 101                         finally
 102                                 FItemList.UnlockList;
 103                         end;
 104                         FAbort := False;
 105                 end;
 106         end;
 107         for i := 0 to FThreadList.Count - 1 do begin
 108                 TDownloadThread(FThreadList[i]).Terminate;
 109                 if TDownloadThread(FThreadList[i]).Suspended then
 110                         TDownloadThread(FThreadList[i]).Resume;
 111         end;
 112
 113 end;
 114
 115 function TThreadControl.GetSuspendThread: TDownloadThread;
 116 var
 117         i: Integer;
 118         DownloadThread: TDownloadThread;
 119 begin
 120         Result := nil;
 121         if GetActiveThreadCount >= FMaxThreadCount then Exit;
 122         for i := 0 to FThreadList.Count - 1 do begin
 123                 if TDownloadThread(FThreadList[i]).Suspended then begin
 124                         Result := TDownloadThread(FThreadList[i]);
 125                         Break;
 126                 end;
 127         end;
 128         if (Result = nil) and (FMaxThreadCount > FThreadList.Count) then begin
 129                 DownloadThread := TDownloadThread.Create(True);
 130                 DownloadThread.FreeOnTerminate := False;
 131                 DownloadThread.Number := FThreadList.Count;
 132                 DownloadThread.OnWorkBegin := WorkBegin;
 133                 DownloadThread.OnWorkEnd := WorkEnd;
 134                 DownloadThread.OnWork := Work;
 135                 DownloadThread.OnDownloadEnd := DownloadEnd;
 136                 DownloadThread.OnDownloadMsg := DownloadMsg;
 137                 FThreadList.Add(DownloadThread);
 138                 Result := DownloadThread;
 139         end;
 140 end;
 141
 142 function TThreadControl.GetActiveThreadCount: Integer;
 143 var
 144         i: Integer;
 145 begin
 146         Result := 0;
 147         for i := 0 to FThreadList.Count - 1 do begin
 148                 if not TDownloadThread(FThreadList[i]).Suspended then
 149                         Inc(Result);
 150         end;
 151 end;
 152
 153 procedure TThreadControl.DownloadAbort;
 154 begin
 155         FAbort := True;
 156 end;
 157
 158 procedure TThreadControl.SetMaxThreadCount(Count: Integer);
 159 begin
 160         if FMaxThreadCount = Count then Exit;
 161         if Count <= 0 then Count := 1;
 162         if Count > 10 then Count := 10;
 163         FMaxThreadCount := Count;
 164 end;
 165
 166 procedure TThreadControl.WorkBegin(Sender: TObject; AWorkMode: TWorkMode; const AWorkCountMax: Integer; Number: Integer);
 167 begin
 168         if Assigned(OnWorkBegin) then
 169                 OnWorkBegin(Sender, AWorkMode, AWorkCountMax, Number);
 170 end;
 171
 172 procedure TThreadControl.WorkEnd(Sender: TObject; AWorkMode: TWorkMode; Number: Integer);
 173 begin
 174         if Assigned(OnWorkEnd) then
 175                 OnWorkEnd(Sender, AWorkMode, Number);
 176 end;
 177
 178 procedure TThreadControl.Work(Sender: TObject; AWorkMode: TWorkMode; const AWorkCount: Integer; Number: Integer);
 179 begin
 180         if Assigned(OnWork) then
 181                 OnWork(Sender, AWorkMode, AWorkCount, Number);
 182 end;
 183
 184 procedure TThreadControl.DownloadEnd(Sender: TObject; Item: TDownloadItem);
 185 begin
 186         if Assigned(OnDownloadEnd) then
 187                 OnDownloadEnd(Sender, Item);
 188 end;
 189
 190 procedure TThreadControl.DownloadMsg(Sender: TObject; Item: TDownloadItem; Msg: string; Icon: TGikoMessageIcon);
 191 begin
 192         if Assigned(OnDownloadMsg) then
 193                 OnDownloadMsg(Sender, Item, Msg, Icon);
 194 end;
 195
 196 end.