Автор: Алексей Вуколов
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Класс-оболочка для объекта синхронизации WaitableTimer.

Класс представляет собой оболочку для объекта синхронизации WaitableTimer,
существующего в операционных системах, основанных на ядре WinNT.

Методы.
--------------
Start - запуск таймера.

Stop - остановка таймера.

Wait - ожидает срабатывания таймера заданное количество миллисекунд и
возвращает результат ожидания.

Свойства.
--------------
Time : TDateTime - дата/время когда должен сработать таймер.

Period : integer - Период срабатывания таймера. Если значение равно 0, то
таймер срабатывает один раз, если же значение отлично от нуля, таймер будет
срабатывать периодически с заданным интервалом, первое срабытывание произойдет
в момент, заданный свойством Time.

LongTime : int64 - альтернативный способ задания времени срабатывания. Время
задается в формате UTC.

Handle : THandle (только чтение) - хендл обекта синхронизации.

LastError : integer (только чтение) - В случае если метод Wait возвращает
wrError, это свойство содержит значение, возвращаемое функцией GetLastError.

Зависимости: Windows, SysUtils, SyncObjs
Автор:       vuk
Copyright:   Алексей Вуколов
Дата:        25 апреля 2002 г.
***************************************************** }

unit wtimer;

interface

uses
  Windows, SysUtils, SyncObjs;

type

  TWaitableTimer = class(TSynchroObject)
  protected
    FHandle: THandle;
    FPeriod: longint;
    FDueTime: TDateTime;
    FLastError: Integer;
    FLongTime: int64;
  public

    constructor Create(ManualReset: boolean;
      TimerAttributes: PSecurityAttributes; const Name: string);
    destructor Destroy; override;

    procedure Start;
    procedure Stop;
    function Wait(Timeout: longint): TWaitResult;

    property Handle: THandle read FHandle;
    property LastError: integer read FLastError;
    property Period: integer read FPeriod write FPeriod;
    property Time: TDateTime read FDueTime write FDueTime;
    property LongTime: int64 read FLongTime write FLongTime;

  end;

implementation

{ TWaitableTimer }

constructor TWaitableTimer.Create(ManualReset: boolean;
  TimerAttributes: PSecurityAttributes; const Name: string);
var
  pName: PChar;
begin
  inherited Create;
  if Name = '' then
    pName := nil
  else
    pName := PChar(Name);
  FHandle := CreateWaitableTimer(TimerAttributes, ManualReset, pName);
end;

destructor TWaitableTimer.Destroy;
begin
  CloseHandle(FHandle);
  inherited Destroy;
end;

procedure TWaitableTimer.Start;
var
  SysTime: TSystemTime;
  LocalTime, UTCTime: FileTime;
  Value: int64 absolute UTCTime;

begin
  if FLongTime = 0 then
  begin
    DateTimeToSystemTime(FDueTime, SysTime);
    SystemTimeToFileTime(SysTime, LocalTime);
    LocalFileTimeToFileTime(LocalTime, UTCTime);
  end
  else
    Value := FLongTime;
  SetWaitableTimer(FHandle, Value, FPeriod, nil, nil, false);
end;

procedure TWaitableTimer.Stop;
begin
  CancelWaitableTimer(FHandle);
end;

function TWaitableTimer.Wait(Timeout: Integer): TWaitResult;
begin
  case WaitForSingleObjectEx(Handle, Timeout, BOOL(1)) of
    WAIT_ABANDONED: Result := wrAbandoned;
    WAIT_OBJECT_0: Result := wrSignaled;
    WAIT_TIMEOUT: Result := wrTimeout;
    WAIT_FAILED:
      begin
        Result := wrError;
        FLastError := GetLastError;
      end;
  else
    Result := wrError;
  end;
end;

end.

Пример использования:

// Пример создания таймера, который срабатывает по алгоритму "завтра в это же
// время и далее с интервалом в одну минуту".

var
  Timer: TWaitableTimer;
begin
  Timer := TWaitableTimer.Create(false, nil, '');
  Timer.Time := Now + 1; //завтра в это же время
  Timer.Period := 60 * 1000; //Интервал в 1 минуту
  Timer.Start; //запуск таймера
end;