delphi 对TThread扩充TSimpleThread

对线程的使用，是每个开发者都应该熟练掌握的，也是进阶的重要一环。

可以这样说，没有线程，连界面假死的问题都解决不了，就更别谈并行处理来提高效率了。

本例对线程进行改进，打造一个基础的线程，以后线程应用都从此类继承，大大节省了代码，提高了效率。

经长期实践，此代码能够应付许多情况，值得一学。

它的应用1：TReadHtmlThread (读网页)

它的应用2: TElegantThread (把多个线程的请求阻塞到另一个线程)

它的应用3: TThreadTimer 多线程 Timer

 unit uSimpleThread;
 interface
 uses
   System.Classes, System.SysUtils, System.SyncObjs;

 type

   // 显示信息,调用方法 DoOnStatusMsg(AMsg);
   TOnStatusMsg = procedure(AMsg: string) of object;

   // 显示调试信息,一般用于显示出错信息,用法 DoOnDebugMsg(AMsg);
   TOnDebugMsg = TOnStatusMsg;

   TSimpleThread = class(TThread)
   public type // "执行过程"的类别定义

     TGeneralProc = procedure; // 普通的,即 procedure DoSomeThing;
     TObjectProc = procedure of object; // 类的,即 TXxxx.DoSomeThign; 用得多
     TAnonymousProc = reference to procedure; // 匿名的
   private type
     TProcKind = (pkGeneral, pkObject, pkAnonymous); // "执行过程"的类别
   private

     FGeneralProc: TGeneralProc;
     FObjProc: TObjectProc;
     FAnoProc: TAnonymousProc;

     FProcKind: TProcKind;

     FEvent: TEvent; // 用于阻塞，它是一个信号量
     FActiveX: boolean; // 是否在线程中支持 Com ,如果你要在线程中访问 IE 的话，就设定为 True

     FOnStatusMsg: TOnStatusMsg;
     FOnDebugMsg: TOnDebugMsg;

     FTagID: integer; // 给线程一个代号,在线程池的时候用来作区别
     FParam: integer; // 给线程一个参数，方便识别

     procedure SelfStart; // 触发线程运行

     procedure DoExecute; // 这个函数里面运行的代码是“线程空间”
     procedure DoOnException(e: exception); // 异常信息显示 调用 DoOnDebugMsg(AMsg);

     procedure SetTagID(const Value: integer);
     procedure SetParam(const Value: integer);

     procedure SetOnStatusMsg(const Value: TOnStatusMsg);
     procedure SetOnDebugMsg(const Value: TOnDebugMsg);

   protected

     FWaitStop: boolean; // 结束标志，可以在继承类中使用它，以确定线程是否停止运行

     procedure DoOnStatusMsg(AMsg: string); // 显示普通信息
     procedure DoOnDebugMsg(AMsg: string); // 显示调式信息

     procedure Execute; override; // 重载 TThread.Execute

     procedure OnThreadProcErr(e: exception); virtual; // 异常发生事件

     procedure WaitThreadStop; // 等待线程结束

     procedure BeforeExecute; virtual; // 看名字,不解释
     Procedure AfterExecute; virtual; // 看名字,不解释

     procedure SleepExceptStopped(ATimeOut: Cardinal); // 这个高大上了，要解释一下。
     { 有时线程没有任务时，就会休息一会儿，但是，休息的时候，可能会接收到退出线程的指令
       此函数就是在休息的时候也检查一下停止指令
     }

   public

     // 改变一下 Create 的参数,AllowedActiveX：是否允许线程代码访问 Com
     constructor Create(AllowedActiveX: boolean = false); reintroduce;

     destructor Destroy; override;

     procedure ExeProcInThread(AProc: TGeneralProc); overload; // 这三个,对外的接口。
     procedure ExeProcInThread(AProc: TObjectProc); overload;
     procedure ExeProcInThread(AProc: TAnonymousProc); overload;

     procedure StartThread; virtual;
     { 启动线程，一般只调用一次。
       以后就由线程的响应事件来执行了
     }

     procedure StopThread; virtual; // 停止线程

     property OnStatusMsg: TOnStatusMsg read FOnStatusMsg write SetOnStatusMsg;
     property OnDebugMsg: TOnDebugMsg read FOnDebugMsg write SetOnDebugMsg;
     property WaitStop: boolean read FWaitStop;
     property TagID: integer read FTagID write SetTagID;
     property Param: integer read FParam write SetParam;

   end;

 implementation

 uses
   ActiveX;

 procedure TSimpleThread.AfterExecute;
 begin
 end;

 procedure TSimpleThread.BeforeExecute;
 begin
 end;

 constructor TSimpleThread.Create(AllowedActiveX: boolean);
 var
   BGUID: TGUID;
 begin
   inherited Create(false);
   FActiveX := AllowedActiveX;
   FreeOnTerminate := false; // 我们要手动Free线程
   CreateGUID(BGUID);
   FEvent := TEvent.Create(nil, true, false, GUIDToString(BGUID));
 end;

 destructor TSimpleThread.Destroy;
 begin
   StopThread; // 先停止
   WaitThreadStop; // 再等待线程停止
   {
     在继承类的 Destroy 中，也要写上这两句. 如:
     暂时未找到更好的办法，这点代码省不了
     destructor TXXThread.Destroy;
     begin
     StopThread;
     WaitThreadStop;
     xxx.Free;
     Inherited;
     end;
   }
   FEvent.Free;
   inherited;
 end;

 procedure TSimpleThread.DoExecute; // 此函数内执行的代码,就是在多线程空间里运行
 begin
   BeforeExecute;
   repeat

     FEvent.WaitFor;
     FEvent.ResetEvent; // 下次waitfor 一直等
     { 这里尝试了很多些，总 SelfStart 觉得有冲突，经过多次修改并使用证明，
       没有必要在这里加锁,因为只调用 startThread 一次，剩下的交给线程影应事件
     }

     if not Terminated then // 如果线程需要退出
     begin

       try

         case FProcKind of
           pkGeneral: FGeneralProc;
           pkObject: FObjProc;
           pkAnonymous: FAnoProc;
         end;

       except

         on e: exception do
         begin
           DoOnException(e);
         end;

       end;

     end;

   until Terminated;
   AfterExecute;
   //代码运行到这里，就表示这个线程不存在了。再也回不去了，必须释放资源了。
 end;

 procedure TSimpleThread.DoOnDebugMsg(AMsg: string);
 begin
   if Assigned(FOnDebugMsg) then
     FOnDebugMsg(AMsg);
 end;

 procedure TSimpleThread.DoOnException(e: exception);
 var
   sErrMsg: string;
 begin
   sErrMsg := 'ClassName:' + ClassName + ##;
   sErrMsg := sErrMsg + 'TagID:' + IntToStr(FTagID) + ##;
   sErrMsg := sErrMsg + 'Param:' + IntToStr(Param) + ##;
   sErrMsg := sErrMsg + 'ErrMsg:' + e.Message + ##;
   DoOnDebugMsg(sErrMsg);
   OnThreadProcErr(e);
 end;

 procedure TSimpleThread.DoOnStatusMsg(AMsg: string);
 begin
   if Assigned(FOnStatusMsg) then
     FOnStatusMsg(AMsg);
 end;

 procedure TSimpleThread.Execute;
 begin
   //是否支持 Com
   if FActiveX then
   begin
     CoInitialize(nil);
     try
       DoExecute;
     finally
       CoUninitialize;
     end;
   end
   else
     DoExecute;
 end;

 procedure TSimpleThread.ExeProcInThread(AProc: TGeneralProc);
 begin
   FGeneralProc := AProc;
   FProcKind := pkGeneral;
   SelfStart;
 end;

 procedure TSimpleThread.ExeProcInThread(AProc: TObjectProc);
 begin
   FObjProc := AProc;
   FProcKind := pkObject;
   SelfStart;
 end;

 procedure TSimpleThread.ExeProcInThread(AProc: TAnonymousProc);
 begin
   FAnoProc := AProc;
   FProcKind := pkAnonymous;
   SelfStart;
 end;

 procedure TSimpleThread.OnThreadProcErr(e: exception);
 begin;
 end;

 procedure TSimpleThread.SelfStart;
 begin
   //经常多次尝试，最终写成这样，运行没有问题
   if FEvent.WaitFor() <> wrSignaled then
     FEvent.SetEvent; // 让waitfor 不再等
 end;

 procedure TSimpleThread.StopThread;
 begin
   //继承类的代码中，需要检查 FWaitStop ，来控制线程结束
   FWaitStop := true;
 end;

 procedure TSimpleThread.SetOnDebugMsg(const Value: TOnDebugMsg);
 begin
   FOnDebugMsg := Value;
 end;

 procedure TSimpleThread.SetOnStatusMsg(const Value: TOnStatusMsg);
 begin
   FOnStatusMsg := Value;
 end;

 procedure TSimpleThread.SetParam(const Value: integer);
 begin
   FParam := Value;
 end;

 procedure TSimpleThread.SetTagID(const Value: integer);
 begin
   FTagID := Value;
 end;

 procedure TSimpleThread.SleepExceptStopped(ATimeOut: Cardinal);
 var
   BOldTime: Cardinal;
 begin
   // sleep 时检测退出指令,以确保线程顺序退出
   // 多个线程同时工作，要保证正确退出，确实不容易
   BOldTime := GetTickCount;
   while not WaitStop do
   begin
     sleep();
     if (GetTickCount - BOldTime) > ATimeOut then
       break;
   end;
 end;

 procedure TSimpleThread.StartThread;
 begin
   FWaitStop := false;
 end;

 procedure TSimpleThread.WaitThreadStop;
 begin
   //等待线程结束
   StopThread;
   Terminate;
   SelfStart;
   WaitFor;
 end;

 end.

uSimpleThread.pas

附：delphi 进阶基础技能说明