unit ExtDLLTimer;
interface
uses Windows, SysUtils, Classes, messages;
const
CTI_MULT_FACTOR = 10000;
CTI_MAXINTERVAL = $8000000000000000;
CTI_MAXINTERVAL_MS = CTI_MAXINTERVAL
div CTI_MULT_FACTOR;
// Timeout to wait for finishing timer-thread
CTI_EXITTIMEOUT = 1000;
type
TAPIWaitableTimer =
class(TThread)
private
FOnTimer : TNotifyEvent;
FTimer,
FCloseEvent,
FPauseEvent,
FExitEvent : Cardinal;
FInterval : Int64;
FRunning,
FContinuous : boolean;
FHandle : HWND;
procedure CLoseHandles;
function GetEnabled: boolean;
procedure ThrowTimerEvent;
procedure SetEnabled(
const Value: boolean);
procedure SetInterval(
const Value: Int64);
protected
procedure Execute;
override;
procedure StartTimer;
procedure StopTimer;
public
constructor Create(AContinuous: boolean; ATimerObject: HWND;
AExitEvent: Cardinal);
reintroduce;
destructor Destroy;
override;
property OnTimer: TNotifyEvent
read FOnTimer
write FOnTimer;
property Enabled: boolean
read GetEnabled
write SetEnabled;
property CloseEvent: Cardinal
read FCloseEvent;
property Interval: Int64
read FInterval
write SetInterval;
end;
TDLLTimer =
class(TObject)
private
FHandle : HWND;
FExitEvent : Cardinal;
FOnTimer : TNotifyEvent;
FTimer : TAPIWaitableTimer;
FContinuous: boolean;
FInterval : Cardinal;
function GetEnabled: boolean;
procedure OnAPITimer(Sender: TObject);
procedure APITimerTerminated(Sender: TObject);
public
constructor Create(AContinuous: boolean);
reintroduce;
destructor Destroy;
override;
procedure WndProc(
var Msg: TMessage);
procedure StartTimer(AInterval: Int64);
procedure StopTimer;
property OnTimer: TNotifyEvent
read FOnTimer
write FOnTimer;
property Enabled: boolean
read GetEnabled;
end;
implementation
{ TAPIWaitableTimer }
constructor TAPIWaitableTimer.Create(AContinuous: boolean; ATimerObject: HWND;
AExitEvent: Cardinal);
begin
inherited create(false);
FHandle := ATimerObject;
FExitEvent := AExitEvent;
FTimer := CreateWaitableTimer(
nil, false, PChar('
'));
FCloseEvent := CreateEvent(
nil, false, false, PChar('
'));
FPauseEvent := CreateEvent(
nil, false, false, PChar('
'));
FRunning := false;
FContinuous := AContinuous;
FreeOnTerminate := true;
SetInterval(1000);
end;
destructor TAPIWaitableTimer.Destroy;
begin
CloseHandles;
SetEvent(FExitEvent);
inherited;
end;
procedure TAPIWaitableTimer.CloseHandles;
begin
if FTimer > 0
then
closehandle(FTimer);
if FCLoseEvent > 0
then
closehandle(FCloseEvent);
if FPauseEvent > 0
then
closehandle(FPauseEvent);
FTimer := 0;
FCloseEvent := 0;
end;
procedure TAPIWaitableTimer.Execute;
var objs :
Array[0..2]
of Cardinal;
lQuit: boolean;
begin
lQuit := false;
if (FTimer > 0)
and (FCloseEvent > 0)
then
begin
objs[0] := FTimer;
objs[1] := FCloseEvent;
objs[2] := FPauseEvent;
repeat
case WaitForMultipleObjects(3, @objs, false, INFINITE)
of
WAIT_OBJECT_0 :
begin
// synchronize(ThrowTimerEvent);
PostMessage(FHandle, WM_TIMER, 0, 0);
FRunning := false;
if FContinuous
then StartTimer;
end;
WAIT_OBJECT_0 + 1: lQuit := true;
WAIT_OBJECT_0 + 2:
case Enabled
of
true : StopTimer;
false : StartTimer;
end;
end;
until lQuit;
end;
Terminate;
end;
function TAPIWaitableTimer.GetEnabled: boolean;
begin
result := (FTimer > 0)
and (FCloseEvent > 0)
and FRunning;
end;
procedure TAPIWaitableTimer.SetEnabled(
const Value: boolean);
begin
if Value <> Enabled
then
SetEvent(FPauseEvent);
if suspended
then
resume;
end;
procedure TAPIWaitableTimer.SetInterval(
const Value: Int64);
begin
FInterval := Value;
if Enabled
then StartTimer;
end;
procedure TAPIWaitableTimer.StartTimer;
const WaitDur = 10;
var Duration: TLargeInteger;
Per : Integer;
begin
// not sure why have to wait, but else timer sometimes behaves corrupted
sleep(WaitDur);
if abs(FInterval) > abs(CTI_MAXINTERVAL_MS)
then
raise Exception.Create('
Maximum Interval exceeded!');
FInterval := FInterval - WaitDur;
Duration := (-1) * FInterval * CTI_MULT_FACTOR;
Per := 0;
FRunning := SetWaitableTimer(FTimer, Duration, Per,
nil,
nil, true);
if not FRunning
then
raise Exception.Create(SysErrorMessage(GetLastError));
if suspended
then
resume;
end;
procedure TAPIWaitableTimer.StopTimer;
begin
FRunning := false;
if not CancelWaitableTimer(FTimer)
then
raise Exception.Create(SysErrorMessage(GetLastError));
end;
procedure TAPIWaitableTimer.ThrowTimerEvent;
begin
if FRunning
and Assigned(FOnTimer)
then
FOnTimer(self);
end;
{ TDLLTimer }
constructor TDLLTimer.Create(AContinuous: boolean);
begin
inherited create;
{$IFDEF MSWINDOWS}
FHandle := Classes.AllocateHWnd(WndProc);
{$ENDIF}
{$IFDEF LINUX}
FHandle := WinUtils.AllocateHWnd(WndProc);
{$ENDIF}
FContinuous := AContinuous;
FExitEvent := CreateEvent(
nil, false, false, '
');
FTimer := TAPIWaitableTimer.Create(AContinuous, FHandle, FExitEvent);
FTImer.OnTimer := OnAPITimer;
FTimer.OnTerminate := APITimerTerminated;
end;
destructor TDLLTimer.Destroy;
begin
{$IFDEF MSWINDOWS}
Classes.DeallocateHWnd(FHandle);
{$ENDIF}
{$IFDEF LINUX}
WinUtils.DeallocateHWnd(FHandle);
{$ENDIF}
FTimer.OnTerminate :=
nil;
ResetEvent(FExitEvent);
SetEvent(FTimer.CloseEvent);
case WaitForSingleObject(FExitEvent, CTI_EXITTIMEOUT)
of
WAIT_OBJECT_0: FTimer :=
nil;
WAIT_TIMEOUT :
raise Exception.Create('
Error releasing DLLTimer');
end;
inherited;
end;
procedure TDLLTimer.APITimerTerminated(Sender: TObject);
var lEnabled: boolean;
begin
lEnabled := FTimer.Enabled;
if Assigned(FTimer.FatalException)
then
raise Exception.Create(
Exception(FTimer.FatalException).
Message)
else
begin
ResetEvent(FExitEvent);
FTimer := TAPIWaitableTimer.Create(FContinuous, FHandle, FExitEvent);
FTImer.OnTimer := OnAPITimer;
FTimer.OnTerminate := APITimerTerminated;
FTimer.Interval := FInterval;
if lEnabled
then
FTimer.StartTimer;
end;
end;
function TDLLTimer.GetEnabled: boolean;
begin
result := FTimer.Enabled;
end;
procedure TDLLTimer.OnAPITimer(Sender: TObject);
begin
if Assigned(FOnTimer)
then
FOnTimer(Sender);
end;
procedure TDLLTimer.StartTimer(AInterval: Int64);
begin
FInterval := AInterval;
FTimer.Interval := AInterval;
FTimer.Enabled := true;;
end;
procedure TDLLTimer.StopTimer;
begin
FTimer.Enabled := false;
end;
procedure TDLLTimer.WndProc(
var Msg: TMessage);
begin
case Msg.Msg
of
WM_TIMER: OnApiTimer(FTimer);
end;
end;
en