Когда-то очень давно я нашел в сети модуль класса - оболочку для объекта синхронизации WaitableTimer, автор Алексей Вуколов. Спасибо большое Алексею, модуль небольшой и очень простой, но мне он не раз пригодился. Привожу здесь его код.
unit wtimer;
{ **** 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 г.
***************************************************** }
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: Cardinal): 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: Cardinal): 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;
По сути здесь зашит функционал будильника. TWaitableTimer нам пригодиться и сейчас. Рассмотрим тело основного потока нашего примера TSparkyThread, то есть метод Execute
procedure TSparkyThread.Execute;
var
yy, mn, dd, hh, mm, ss, ms: Word;
SUCCESS: HResult;
CurDT: TDateTime;
begin
CurDT := Now;
DecodeDateTime(CurDT, yy, mn, dd, hh, mm, ss, ms);
With ZTService do
begin
TimeRun := EncodeDateTime(yy, mn, dd, h1, m1, s1, 0);
if CurDT > TimeRun then
begin
TimeRun := IncHour(TimeRun, period);//IncDay(TimeRun);
end;
WriteLog('Таймер установлен на ' + DateTimeToStr(TimeRun));
Timer := TWaitableTimer.Create(False, nil, '');
try
Timer.Time := TimeRun; // время србатывания
Timer.period := period*60*60*1000;
Timer.Start; // запуск таймера
while not Terminated do
if Timer.Wait(INFINITE) <> wrError then
begin
if not Terminated then
begin
WriteLog('Таймер сработал');
SUCCESS := CoInitialize(nil);
try
ExeWork;
finally
case SUCCESS of
S_OK, S_FALSE:
CoUninitialize;
end;
WriteLog('Загрузка завершена');
TimeRun := IncHour(TimeRun, period);
WriteLog('Таймер установлен на ' + DateTimeToStr(TimeRun));
end;
end;
end else
WriteLog('Ошибка таймера');
finally
Timer.Free;
end;
end;
end;
Что мы здесь видим... Для начала устанавливается время срабатывания таймера, часы минуты и секунды мы берем из ранее считанного INI-файла и прибавляем к текущей дате. Также из INI взят период в часах через который срабатывание повторяется. Важен вызов CoInitialize, поскольку эта служба планирует работать с какой-то базой данных через ADO, без этой функции ничего не выйдет. Ну и, конечно, логирование, куда без него. А основная работа будет выполняться внутри ExeWork.
procedure TZTService.ExeWork;
var
fld: TField;
Handles: array of THandle;
Threads: array of TPOThread;
I,N: Integer;
begin
ADOConnection1.Connected := True;
try
if ADOConnection1.Connected then
begin
WriteLog('Соединение с SQL-сервером установлено');
PoTable.Open;
PoTable.First;
N:= PoTable.RecordCount;
SetLength(Handles, N);
SetLength(Threads, N);
I:=0;
while not PoTable.Eof do
begin
po := Trim(PoTable.FieldByName('short_name').AsString);
WriteLog('Начало загрузки данных по ' + po);
fld := PoTable.FieldByName('oik');
if not (fld.IsNull or (Trim(fld.AsString) = '')) then
oik := Trim(PoTable.FieldByName('oik').AsString)
else oik := '';
Threads[I]:= TPOThread.Create(PoTable.FieldByName('id').AsInteger, oik);
Handles[I] := Threads[I].Handle;
Inc(I);
PoTable.Next;
end;
// Wait until threads terminate
// This may take up to ArrLen - 1 seconds
WaitForMultipleObjects(N, @Handles, True, INFINITE);
// Destroy thread instances
for I := 0 to N - 1 do
Threads[I].Free;
end
else
begin
WriteLog('ОШИБКА! Соединение с SQL-сервером НЕ УСТАНОВЛЕНО!');
end;
finally
if ADOConnection1.Connected then
ADOConnection1.Close;
end;
end;
Как можно отметить в выше приведенном коде происходит соединение с неким SQL-сервером, далее чтение записей с таблицы (поясню, что компоненты таблицы и коннекшена к БД, в данном случае, лежат на форме службы). На основании количества подходящих записей из таблицы создается нужное количество потоков, хэндлеры и объекты которых запоминаем в двух массивах. После того как дождались выхода из функции WaitForMultipleObjects(N, @Handles, True, INFINITE) - а это значит все потоки завершили работу - удаляем их, освобождая память. То что происходит внутри каждого из этих потоков неважно, в моем случае это было чтение данных с серверов телемеханики, единственное что там надо быть уже более внимательным с синхронизацией, чтобы не допустить одновременного обращения к каким-либо общим объектам или переменным, но это уже другая история...
