agthread.pas

Tread Component for Delphi

unit agThread;

{$I AG.INC}

interface

uses Windows, Classes;

type
  TThreadEx = class (TThread)
  private
    FOnExecute: TNotifyEvent;
  protected
    procedure Execute; override;
  public
    property OnExecute: TNotifyEvent read FOnExecute write FOnExecute;
    property Terminated;
  end;

  TagThread = class (TComponent)
  private
    FThread: TThreadEx;
    FSyncMethod: TNotifyEvent;
    FSyncParams: Pointer;
    FStreamedSuspended, FCycled: Boolean;
    FOnExecute, FOnException: TNotifyEvent;
    FInterval: integer;
    procedure InternalSynchronize;
    function GetHandle: THandle;
    function GetThreadID: THandle;
    function GetOnTerminate: TNotifyEvent;
    procedure SetOnTerminate(Value: TNotifyEvent);
    function GetPriority: TThreadPriority;
    procedure SetPriority(Value: TThreadPriority);
    function GetReturnValue: Integer;
    procedure SetReturnValue(Value: Integer);
    function GetSuspended: Boolean;
    procedure SetSuspended(Value: Boolean);
    function GetTerminated: boolean;
  protected
    procedure DoExecute(Sender: TObject); virtual;
    procedure DoException(Sender: TObject); virtual;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Execute;
    procedure Synchronize(Method: TThreadMethod);
    procedure SynchronizeEx(Method: TNotifyEvent; Params: Pointer);
    procedure Suspend;
    procedure Resume;
    procedure Terminate;
    function TerminateWaitFor: Integer;
    procedure TerminateHard;
    function WaitFor: Integer;
    property ReturnValue: Integer read GetReturnValue write SetReturnValue;
    property Handle: THandle read GetHandle;
    property ThreadID: THandle read GetThreadID;
    property Terminated: Boolean read GetTerminated;
    procedure Delay(MSecs: Longint);
  published
    property OnTerminate: TNotifyEvent read GetOnTerminate write SetOnTerminate;
    property Priority: TThreadPriority read GetPriority write SetPriority;
    property Suspended: Boolean read GetSuspended write SetSuspended default True;
    property OnExecute: TNotifyEvent read FOnExecute write FOnExecute;
    property OnException: TNotifyEvent read FOnException write FOnException;
    property Interval: integer read FInterval write FInterval;
    property Cycled: boolean read FCycled write FCycled;
  end;

implementation

uses SysUtils, Forms;

procedure TThreadEx.Execute;
begin
  if Assigned(FOnExecute) then FOnExecute(Self);
end;

type
  TThreadHack = class (TThreadEx);

constructor TagThread.Create(AOwner: TComponent);
begin
  inherited;
  FStreamedSuspended := True;
  FThread := TThreadEx.Create(True);
  FThread.OnExecute := DoExecute;
  FInterval:=0;
  FCycled:=false;
end;

destructor TagThread.Destroy;
begin
  FThread.Free;
  inherited;
end;

procedure TagThread.DoExecute(Sender: TObject);
begin
  repeat
    Delay(FInterval);
    if FThread.Terminated then break;
    try
      if Assigned(FOnExecute) then FOnExecute(Self);
    except
      SynchronizeEx(DoException,ExceptObject);
    end;
  until FThread.Terminated or not(Cycled);
end;

procedure TagThread.DoException(Sender: TObject);
var
  s: string;
begin
  if Assigned(FOnException) then
    FOnException(Sender)
  else begin
    s:=Format('Thread %s raised exception class %s with message ''%s''.',
      [Name,Exception(Sender).ClassName,Exception(Sender).Message]);
    Application.MessageBox(PChar(s),PChar(Application.Title),
      MB_ICONERROR or MB_SETFOREGROUND or MB_APPLMODAL);
  end;
end;

function TagThread.GetHandle: THandle;
begin
  Result := FThread.Handle;
end;

function TagThread.GetOnTerminate: TNotifyEvent;
begin
  Result := FThread.OnTerminate;
end;

function TagThread.GetPriority: TThreadPriority;
begin
  Result := FThread.Priority;
end;

function TagThread.GetReturnValue: Integer;
begin
  Result := TThreadHack(FThread).ReturnValue;
end;

function TagThread.GetSuspended: Boolean;
begin
  if not (csDesigning in ComponentState) then
    Result := FThread.Suspended else
    Result := FStreamedSuspended;
end;

procedure TagThread.Execute;
begin
  TerminateHard;
  FThread.Resume;
end;

procedure TagThread.Loaded;
begin
  inherited;
  SetSuspended(FStreamedSuspended);
end;

procedure TagThread.SetOnTerminate(Value: TNotifyEvent);
begin
  FThread.OnTerminate := Value;
end;

procedure TagThread.SetPriority(Value: TThreadPriority);
begin
  FThread.Priority := Value;
end;

procedure TagThread.SetReturnValue(Value: Integer);
begin
  TThreadHack(FThread).ReturnValue := Value;
end;

procedure TagThread.SetSuspended(Value: Boolean);
begin
  if not (csDesigning in ComponentState) then
  begin
    if (csLoading in ComponentState) then
      FStreamedSuspended := Value else
      FThread.Suspended := Value;
  end else
    FStreamedSuspended := Value;
end;

procedure TagThread.Suspend;
begin
  FThread.Suspend;
end;

procedure TagThread.Synchronize(Method: TThreadMethod);
begin
  TThreadHack(FThread).Synchronize(Method);
end;

procedure TagThread.InternalSynchronize;
begin
  FSyncMethod(FSyncParams);
end;

procedure TagThread.SynchronizeEx(Method: TNotifyEvent; Params: Pointer);
begin
  if not Assigned(FSyncMethod) then
  begin
    FSyncMethod := Method; FSyncParams := Params;
    try
      TThreadHack(FThread).Synchronize(InternalSynchronize);
    finally
      FSyncMethod := nil; FSyncParams := nil;
    end;
  end;
end;

procedure TagThread.Resume;
begin
  FThread.Resume;
end;

procedure TagThread.Terminate;
begin
  FThread.Terminate;
end;

function TagThread.TerminateWaitFor: Integer;
begin
  Terminate;
  Result:=WaitFor;
end;

procedure TagThread.TerminateHard;
var
  FTmp: TThreadEx;
begin
  TerminateThread(FThread.Handle, 0);
  FTmp := TThreadEx.Create(True);
  try
    FTmp.Priority := Self.Priority;
    FTmp.OnExecute := DoExecute;
    FTmp.OnTerminate := Self.OnTerminate;
  except
    FTmp.Free;
    raise;
  end;
  FThread.Free;
  FThread := FTmp;
end;

function TagThread.WaitFor: Integer;
begin
  Result := FThread.WaitFor;
end;

function TagThread.GetTerminated: boolean;
begin
  Result:=FThread.Terminated;
end;

function TagThread.GetThreadID: THandle;
begin
  Result:=FThread.ThreadID;
end;

procedure TagThread.Delay(MSecs: Longint);
var
  FirstTickCount, Now: Longint;
begin
  if MSecs < 0 then exit;
  FirstTickCount := GetTickCount;
  repeat
    Sleep(1);
    Now := GetTickCount;
  until (Now - FirstTickCount >= MSecs) or (Now < FirstTickCount) or Terminated;
end;

end.