delphi 对TThread扩充TSimpleThread

对线程的使用，是每个开发者都应该熟练掌握的，也是进阶的重要一环。
可以这样说，没有线程，连界面假死的问题都解决不了，就更别谈并行处理来提高效率了。
本例对线程进行改进，打造一个基础的线程，以后线程应用都从此类继承，大大节省了代码，提高了效率。
经长期实践，此代码能够应付许多情况，值得一学。
它的应用2: TElegantThread (把多个线程的请求阻塞到另一个线程)
 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 进阶基础技能说明
巴特西

delphi 对TThread扩充TSimpleThread

最新文章

热门文章
