tmrpool.pas

Delphi 开发的的热键操作 很值得看的

unit TmrPool;

interface

uses
  Windows, Messages, SysUtils, Classes;

const
  CM_TIMERELAPSED = WM_USER+1010;

type
  TCMTimerElapsed = record
    Msg: Word;
    MilliSeconds: Word;
    Count: Longint;
    Result: Longint;
  end;

  TObjectTimeInfo = class
    TimeObject : TObject;
    Active     : Boolean;
    Count      : Longint;
  end;

  TTimerPool = class;

  TTimingThread = class(TThread)
  private
    FTime: DWord;
    FTimerPool: TTimerPool;
    FResolution: Integer;
  protected
    procedure TimerElapsed;
    procedure Execute; override;
  public
    constructor Create(AOwner: TTimerPool; Resolution: integer);
    property Resolution: Integer read FResolution write FResolution;
  end;

  TTimerPool = class(TComponent)
  private
    FThread    : TTimingThread;
    FObjects   : TList;
  protected
    procedure TimerElapsed(MSecs: Integer);
    function TimingNeeded: Boolean;
    procedure CheckForTiming;
    function  FindIndex(AObject: TObject): integer;
    function  FindRegisteredComponent(AObject: TObject): TObjectTimeInfo;
    procedure Notification(AComponent: TComponent; AOperation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure NotifyRegister(AObject: TObject; AActive: Boolean);
    procedure NotifyUnregister(AObject: TObject);
  end;

var 
  TimerPool: TTimerPool;

implementation

uses Forms, mmSystem;

{ TTimingThread }
constructor TTimingThread.Create(AOwner: TTimerPool; Resolution: Integer);
begin
  inherited Create(False);
  FTimerPool := AOwner;
  FResolution := Resolution;
  FreeOnTerminate := True;
end;

procedure TTimingThread.TimerElapsed;
begin
  if Assigned(FTimerPool) then FTimerPool.TimerElapsed(timeGetTime-FTime);
end;

procedure TTimingThread.Execute;
begin
  repeat
    FTime := timeGetTime;
    repeat
    until timeGetTime-FTime>=FResolution;
    if not Terminated then Synchronize(TimerElapsed);
  until Terminated;
end;

{ TTimerPool }
constructor TTimerPool.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FObjects := TList.Create;
  FThread := nil;
end;

destructor TTimerPool.Destroy;
begin
  while FObjects.Count>0 do
   NotifyUnregister(TObjectTimeInfo(FObjects[0]).TimeObject);
  if FThread<>nil then FThread.Terminate;
  FThread.Free;
  FObjects.Free;
end;

procedure TTimerPool.TimerElapsed(MSecs: Integer);
var
  i    : integer;
  TEMsg: TCMTimerElapsed;
begin
  TEMsg.Msg := CM_TIMERELAPSED;
  for i:=0 to FObjects.Count-1 do
   with TObjectTimeInfo(FObjects[i]) do
    begin
      if Active then
       begin
         inc(Count);
         TEMsg.MilliSeconds := MSecs;
         TEMsg.Count := Count;
         TimeObject.Dispatch(TEMsg);
       end;
    end;
end;

function TTimerPool.FindIndex(AObject: TObject): integer;
var
  i : integer;
begin
  Result := -1;
  for i:=0 to FObjects.Count-1 do
   if TObjectTimeInfo(FObjects[i]).TimeObject = AObject then
    begin
      Result := i;
      Exit;
    end;
end;

function TTimerPool.FindRegisteredComponent(AObject: TObject): TObjectTimeInfo;
var
  iIndex : integer;
begin
  iIndex := FindIndex(AObject);
  if iIndex=-1 then
   Result := nil
  else
   Result := TObjectTimeInfo(FObjects[iIndex]);
end;

function TTimerPool.TimingNeeded: Boolean;
var
  i : integer;
begin
  Result := True;
  for i:=0 to FObjects.Count-1 do
   if TObjectTimeInfo(FObjects[i]).Active then
    Exit;
  Result := False;
end;

procedure TTimerPool.CheckForTiming;
begin
  if TimingNeeded and (FThread=nil) then
   FThread := TTimingThread.Create(Self, 5)
  else if not TimingNeeded and (FThread<>nil) then
   begin
     FThread.Terminate;
     FThread := nil;
   end;
end;

procedure TTimerPool.NotifyRegister(AObject: TObject; AActive: Boolean);
var
  ObjTimeInfo : TObjectTimeInfo;
  AddNew       : Boolean;
begin
  ObjTimeInfo := FindRegisteredComponent(AObject);
  AddNew := (ObjTimeInfo = nil);
  if AddNew then ObjTimeInfo := TObjectTimeInfo.Create;
  with ObjTimeInfo do
   begin
     TimeObject := AObject;
     Active := AActive;
   end;
  if AddNew then
   begin
     ObjTimeInfo.Count := 0;
     if AObject is TComponent then TComponent(AObject).FreeNotification(Self);
     FObjects.Add(ObjTimeInfo);
   end;
  CheckForTiming;
end;

procedure TTimerPool.NotifyUnregister(AObject: TObject);
var
  iIndex : Integer;
  ObjInf : TObjectTimeInfo;
begin
  iIndex := FindIndex(AObject);
  if iIndex<>-1 then
   begin
     ObjInf := TObjectTimeInfo(FObjects[iIndex]);
     FObjects.Delete(iIndex);
     ObjInf.Free;
     CheckForTiming;
   end;
end;

procedure TTimerPool.Notification(AComponent: TComponent; AOperation: TOperation);
begin
  if (AOperation=opRemove) and (AComponent is TComponent) then
   NotifyUnregister(AComponent);
  inherited Notification(AComponent, AOperation);
end;

initialization
  TimerPool := TTimerPool.Create(nil);
finalization
  TimerPool.Free;
  TimerPool := nil;
end.