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 + #13#10;
  sErrMsg := sErrMsg + 'TagID:' + IntToStr(FTagID) + #13#10;
  sErrMsg := sErrMsg + 'Param:' + IntToStr(Param) + #13#10;
  sErrMsg := sErrMsg + 'ErrMsg:' + e.Message + #13#10;
  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(0) <> 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(50);
    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.

附：delphi 進階基礎技能說明