828
社区成员
发帖
与我相关
我的任务
分享
unit WaitTimerU;
interface
uses
Classes, Windows, Consts;
type
TWaitTimer = class(TComponent)
private
FWaitableTimer: THandle;
FInterval: Cardinal;
FOnTimer: TNotifyEvent;
FEnabled: Boolean;
procedure UpdateTimer;
procedure SetEnabled(Value: Boolean);
procedure SetInterval(Value: Cardinal);
procedure SetOnTimer(Value: TNotifyEvent);
protected
procedure Timer; dynamic;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Enabled: Boolean read FEnabled write SetEnabled default True;
property Interval: Cardinal read FInterval write SetInterval default 1000;
property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
end;
implementation
procedure TimerAPCProc(lpArgToCompletionRoutine: Pointer; dwTimerLowValue: DWORD;
dwTimerHighValue: DWORD); stdcall;
begin
TWaitTimer(lpArgToCompletionRoutine).Timer;
SleepEx(INFINITE, True);
end;
function WaitTimerThreadFun(P: Pointer): Integer; stdcall;
var
DueTime: Int64;
begin
with TWaitTimer(P) do
begin
DueTime := -Int64(Interval)*10000;
if SetWaitableTimer(FWaitableTimer, DueTime, Interval, @TimerAPCProc, P, False) then
begin
SleepEx(INFINITE, True);
end
else
raise EOutOfResources.Create(SNoTimers);
end;
Result := 0;
end;
{ TWaitTimer }
constructor TWaitTimer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FEnabled := True;
FInterval := 1000;
FWaitableTimer := CreateWaitableTimer(nil, False, nil);
end;
destructor TWaitTimer.Destroy;
begin
FEnabled := False;
UpdateTimer;
CloseHandle(FWaitableTimer);
inherited;
end;
procedure TWaitTimer.SetEnabled(Value: Boolean);
begin
if Value <> FEnabled then
begin
FEnabled := Value;
UpdateTimer;
end;
end;
procedure TWaitTimer.SetInterval(Value: Cardinal);
begin
if Value <> FInterval then
begin
FInterval := Value;
UpdateTimer;
end;
end;
procedure TWaitTimer.SetOnTimer(Value: TNotifyEvent);
begin
FOnTimer := Value;
UpdateTimer;
end;
procedure TWaitTimer.Timer;
begin
if Assigned(FOnTimer) then FOnTimer(Self);
end;
procedure TWaitTimer.UpdateTimer;
var
ID: DWORD;
begin
CancelWaitableTimer(FWaitableTimer);
if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
begin
CreateThread(nil, 0, @WaitTimerThreadFun, Self, 0, ID);
end;
end;
end.
unit WaitTimerU;
interface
uses
Classes, Windows, Consts, SysCall;
type
TWaitTimer = class(TComponent)
private
FWaitableTimer: THandle;
FWaitObject: THandle;
FInterval: Cardinal;
FOnTimer: TNotifyEvent;
FEnabled: Boolean;
procedure UpdateTimer;
procedure SetEnabled(Value: Boolean);
procedure SetInterval(Value: Cardinal);
procedure SetOnTimer(Value: TNotifyEvent);
protected
procedure Timer; dynamic;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Enabled: Boolean read FEnabled write SetEnabled default True;
property Interval: Cardinal read FInterval write SetInterval default 1000;
property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
end;
function RegisterWaitForSingleObject(var phNewWaitObject: THandle; hObject: THandle;
Callback: Pointer; Context: Pointer; dwMilliseconds: DWORD; dwFlags: DWORD): BOOL; stdcall;
function UnregisterWait(WaitHandle: THandle): BOOL; stdcall;
implementation
function RegisterWaitForSingleObject; external kernel32;
function UnregisterWait; external kernel32;
procedure TimerAPCProc(lpParameter: Pointer; TimerOrWaitFired: BOOL); stdcall;
begin
TWaitTimer(lpParameter).Timer;
end;
{ TWaitTimer }
constructor TWaitTimer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FEnabled := True;
FInterval := 1000;
FWaitableTimer := CreateWaitableTimer(nil, False, nil);
RegisterWaitForSingleObject(FWaitObject, FWaitableTimer, @TimerAPCProc, Self, INFINITE, 0);
end;
destructor TWaitTimer.Destroy;
begin
FEnabled := False;
UpdateTimer;
UnregisterWait(FWaitObject);
CloseHandle(FWaitableTimer);
inherited;
end;
procedure TWaitTimer.SetEnabled(Value: Boolean);
begin
if Value <> FEnabled then
begin
FEnabled := Value;
UpdateTimer;
end;
end;
procedure TWaitTimer.SetInterval(Value: Cardinal);
begin
if Value <> FInterval then
begin
FInterval := Value;
UpdateTimer;
end;
end;
procedure TWaitTimer.SetOnTimer(Value: TNotifyEvent);
begin
FOnTimer := Value;
UpdateTimer;
end;
procedure TWaitTimer.Timer;
begin
if Assigned(FOnTimer) then FOnTimer(Self);
end;
procedure TWaitTimer.UpdateTimer;
var
DueTime: Int64;
begin
CancelWaitableTimer(FWaitableTimer);
if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
begin
DueTime := -Int64(Interval)*10000;
if not SetWaitableTimer(FWaitableTimer, DueTime, Interval, nil, nil , True) then
raise EOutOfResources.Create(SNoTimers);
end;
end;
end.
unit WaitTimerU;
interface
uses
Classes, Windows, Consts;
type
TWaitTimer = class(TComponent)
private
FWaitableTimer: THandle;
FWaitObject: THandle;
FInterval: Cardinal;
FOnTimer: TNotifyEvent;
FEnabled: Boolean;
procedure UpdateTimer;
procedure SetEnabled(Value: Boolean);
procedure SetInterval(Value: Cardinal);
procedure SetOnTimer(Value: TNotifyEvent);
protected
procedure Timer; dynamic;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Enabled: Boolean read FEnabled write SetEnabled default True;
property Interval: Cardinal read FInterval write SetInterval default 1000;
property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
end;
function RegisterWaitForSingleObject(var phNewWaitObject: THandle; hObject: THandle;
Callback: Pointer; Context: Pointer; dwMilliseconds: DWORD; dwFlags: DWORD): BOOL; stdcall;
function UnregisterWait(WaitHandle: THandle): BOOL; stdcall;
implementation
function RegisterWaitForSingleObject; external kernel32;
function UnregisterWait; external kernel32;
procedure TimerAPCProc(lpParameter: Pointer; TimerOrWaitFired: BOOL); stdcall;
begin
TWaitTimer(lpParameter).Timer;
end;
{ TWaitTimer }
constructor TWaitTimer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FEnabled := True;
FInterval := 1000;
FWaitableTimer := CreateWaitableTimer(nil, False, nil);
RegisterWaitForSingleObject(FWaitObject, FWaitableTimer, @TimerAPCProc, Self, INFINITE, 0);
end;
destructor TWaitTimer.Destroy;
begin
FEnabled := False;
UpdateTimer;
UnregisterWait(FWaitObject);
CloseHandle(FWaitableTimer);
inherited;
end;
procedure TWaitTimer.SetEnabled(Value: Boolean);
begin
if Value <> FEnabled then
begin
FEnabled := Value;
UpdateTimer;
end;
end;
procedure TWaitTimer.SetInterval(Value: Cardinal);
begin
if Value <> FInterval then
begin
FInterval := Value;
UpdateTimer;
end;
end;
procedure TWaitTimer.SetOnTimer(Value: TNotifyEvent);
begin
FOnTimer := Value;
UpdateTimer;
end;
procedure TWaitTimer.Timer;
begin
if Assigned(FOnTimer) then FOnTimer(Self);
end;
procedure TWaitTimer.UpdateTimer;
var
DueTime: Int64;
begin
CancelWaitableTimer(FWaitableTimer);
if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
begin
DueTime := -Int64(Interval)*10000;
if not SetWaitableTimer(FWaitableTimer, DueTime, Interval, nil, nil , True) then
raise EOutOfResources.Create(SNoTimers);
end;
end;
end.
unit SysCall;
interface
uses
Windows;
const
// By default, the callback function is queued to a non-I/O worker thread.
WT_EXECUTEDEFAULT = $00000000;
// The callback function is invoked by the timer thread itself. This flag should be used only for short tasks or it could affect other timer operations.
// The callback function is queued as an APC. It should not perform alertable wait operations.
WT_EXECUTEINTIMERTHREAD = $00000020;
// The callback function is queued to an I/O worker thread. This flag should be used if the function should be executed in a thread that waits in an alertable state.
// The callback function is queued as an APC. Be sure to address reentrancy issues if the function performs an alertable wait operation.
WT_EXECUTEINIOTHREAD = $00000001;
// The callback function is queued to a thread that never terminates. It does not guarantee that the same thread is used each time. This flag should be used only for short tasks or it could affect other timer operations.
// Note that currently no worker thread is truly persistent, although no worker thread will terminate if there are any pending I/O requests.
WT_EXECUTEINPERSISTENTTHREAD = $00000080;
// The callback function can perform a long wait. This flag helps the system to decide if it should create a new thread.
WT_EXECUTELONGFUNCTION = $00000010;
// The timer will be set to the signaled state only once.
WT_EXECUTEONLYONCE = $00000008;
// Callback functions will use the current access token, whether it is a process or impersonation token. If this flag is not specified, callback functions execute only with the process token.
WT_TRANSFER_IMPERSONATION = $00000100;
type
TWaitOrTimerCallback = procedure(
lpParameter: pointer;
TimerOrWaitFired: BOOL
);stdcall;
function CreateTimerQueue: THandle;stdcall;
function DeleteTimerQueueEx(
TimerQueue: THandle;
CompletionEvent: THandle
): BOOL;stdcall;
function CreateTimerQueueTimer(
var phNewTimer: THandle;
TimerQueue: THandle;
Callback: pointer; // WAITORTIMERCALLBACK
Parameter: pointer;
DueTime: DWORD;
Period: DWORD;
Flags: ULONG
): BOOL;stdcall;
function DeleteTimerQueueTimer(
TimerQueue: THandle;
Timer: THandle;
CompletionEvent: THandle
): BOOL;stdcall;
function ChangeTimerQueueTimer(
TimerQueue: THandle;
Timer: THandle;
DueTime: ULONG;
Period: ULONG
): BOOL;stdcall;
function RegisterWaitForSingleObject(
var phNewWaitObject: THandle;
hObject: THandle;
Callback: pointer; // WAITORTIMERCALLBACK
Context: pointer;
dwMilliseconds: DWORD;
dwFlags: DWORD
): BOOL;stdcall;
function UnregisterWait(
WaitHandle: THandle
): BOOL;stdcall;
function UnregisterWaitEx(
WaitHandle: THandle;
CompletionEvent: THandle
): BOOL;stdcall;
function QueueUserWorkItem(
cbFunction: pointer; // LPTHREAD_START_ROUTINE
Context: pointer;
Flags: DWORD
): BOOL;stdcall;
function OpenThread(
dwDesiredAccess: DWORD;
bInheritHandle: BOOL;
dwThreadId: DWORD
): DWORD;stdcall;
// ATL functions
function AtlAxWinInit(): BOOL;stdcall;
function AtlAxAttachControl(
const pControl: IUnknown;
const hWnd: HWND;
out ppUnkContainer): HRESULT;cdecl;
implementation
const
atl = 'atl.dll';
function CreateTimerQueue;external kernel32;
function DeleteTimerQueueEx;external kernel32;
function CreateTimerQueueTimer;external kernel32;
function DeleteTimerQueueTimer;external kernel32;
function ChangeTimerQueueTimer;external kernel32;
function RegisterWaitForSingleObject;external kernel32;
function UnregisterWait;external kernel32;
function UnregisterWaitEx;external kernel32;
function QueueUserWorkItem;external kernel32;
function OpenThread;external kernel32;
// ATL functions
function AtlAxWinInit;external atl;
function AtlAxAttachControl;external atl;
end.