?? hirestim.pas
字號(hào):
unit HiResTim;
interface
uses
Windows, MMSystem, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
THiResTimer = class;
EHiResTimer = class( Exception );
TTimerThread = class( TThread )
private
protected
public
hr: THiResTimer;
procedure Execute; override;
end;
THiResTimer = class( TComponent )
private
nID: UINT;
FEnabled: boolean;
FInterval: UINT;
FResolution: UINT;
FOnTimer: TNotifyEvent;
hTimerEvent: THandle;
bPaused: boolean;
timerThread: TTimerThread;
procedure CreateTimer;
protected
procedure SetEnabled( b: boolean );
public
constructor Create( AOwner: TComponent ); override;
destructor Destroy; override;
procedure Pause;
procedure Resume;
published
property Enabled: boolean read FEnabled write SetEnabled default FALSE;
property Interval: UINT read FInterval write FInterval default 100;
property Resolution: UINT read FResolution write FResolution default 100;
property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
end;
procedure Register;
implementation
procedure TimerCallback( uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD ); stdcall;
var
hr: THiResTimer;
begin
hr := THiResTimer( dwUser );
if hr <> nil then
if not hr.bPaused then
SetEvent( hr.hTimerEvent );
end;
procedure TTimerThread.Execute;
begin
while not Terminated and ( hr <> nil ) do
begin
application.ProcessMessages;
WaitForSingleObject( hr.hTimerEvent, INFINITE );
if Assigned( hr.FOnTimer ) then
hr.FOnTimer( hr );
end;
end;
constructor THiResTimer.Create( AOwner: TComponent );
var
dwDummy: DWORD;
begin
inherited Create( AOwner );
FEnabled := FALSE;
FInterval := 100;
FResolution := 100;
bPaused := FALSE;
hTimerEvent := CreateEvent( nil, FALSE, FALSE, nil );
end;
destructor THiResTimer.Destroy;
begin
Enabled := FALSE;
CloseHandle( hTimerEvent );
inherited Destroy;
end;
procedure THiResTimer.SetEnabled( b: boolean );
begin
if b and ( csDesigning in ComponentState ) then
begin
ShowMessage( 'Set to True in Form''s OnShow event' );
Exit;
end;
if b <> FEnabled then
begin
if b then
begin
if not ( csDesigning in ComponentState ) then
begin
timerThread := TTimerThread.Create( TRUE );
timerThread.hr := self;
timerThread.FreeOnTerminate := TRUE;
timerThread.Resume;
CreateTimer;
end;
end
else
begin
if not ( csDesigning in ComponentState ) then
begin
timeKillEvent( nID );
TerminateThread( timerThread.Handle, 0 );
timerThread.Free;
end;
end;
FEnabled := b;
end;
end;
procedure THiResTimer.CreateTimer;
var
lpTimerProc: TFNTimeCallBack;
begin
lpTimerProc := @TimerCallback;
nID := timeSetEvent( FInterval, FResolution, lpTimerProc, DWORD( self ), TIME_PERIODIC );
if nID = 0 then
begin
FEnabled := FALSE;
raise EHiResTimer.Create( 'Unable to create a timer' );
end;
end;
procedure THiResTimer.Pause;
begin
if Enabled then
timerThread.Suspend;
end;
procedure THiResTimer.Resume;
begin
if Enabled then
timerThread.Resume;
end;
procedure Register;
begin
RegisterComponents( 'NonVis', [THiResTimer] );
end;
end.
?? 快捷鍵說明
復(fù)制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號(hào)
Ctrl + =
減小字號(hào)
Ctrl + -