SetTimer bir fonksiyonun belli bir süre bitiminde çalıştırılmasını sağlar. Delphi'deki Timer nesnesi de aslında SetTimer kullanır.
Bir başka forum sitesinde bulduğum aşağıdaki örneği inceleyin.
Alıntı:
windowsun api settimer fonksiyonunuda kullanabiliriz.
bunu yaparken unitlerimiz içinde diğer unitlere bağımlı(classes, messages vs.)
kalmadan exeyi şişirmeden bu leziz uygulamayı inceleyebilirsiniz..
|
PHP Kodu:
Main.DPR
Program Main;
uses
Windows, ExTimer//, Dialogs;
type
TMain = class(TObject)
Procedure OnTimer;
private
protected
public
end;
Var
AMain:TMain;
MyTimer:TExTimer;
Procedure TMain.OnTimer;
Begin
MyTimer.Enabled:=False;
// ShowMEssage('dasda');
MyTimer.Enabled:=True;
End;
begin
AMain:=TMain.Create;
MyTimer:=TExTimer.Create;
MyTimer.Interval:=1;
MyTimer.Enabled:=True;
MyTimer.OnTimer:=AMain.OnTimer;
Repeat
MyTimer.ProcessMessages;
Sleep(1);
Until (1=0);
MyTimer.Destroy;
AMain.Destroy;
end.
---------------------------------------------------------------
ExTimer.Pas
-----------
unit ExTimer;
interface
uses Windows;
type
PMessage = ^TMessage;
TMessage = packed record
Msg: Cardinal;
case Integer of
0: (
WParam: Longint;
LParam: Longint;
Result: Longint);
1: (
WParamLo: Word;
WParamHi: Word;
LParamLo: Word;
LParamHi: Word;
ResultLo: Word;
ResultHi: Word);
end;
Type
TNotifyEvent = procedure of object;
TExTimer = class(TObject)
private
FInterval: Cardinal;
FWindowHandle: HWND;
FOnTimer: TNotifyEvent;
FEnabled: Boolean;
function ProcessMessage(var Msg: TMsg): Boolean;
procedure UpdateTimer;
procedure SetEnabled(Value: Boolean);
procedure SetInterval(Value: Cardinal);
procedure SetOnTimer(Value: TNotifyEvent);
procedure WndProc(var Msg: TMessage);
protected
procedure Timer; dynamic;
public
constructor Create;
destructor Destroy; override;
published
procedure ProcessMessages;
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
{ Free an object instance }
const
WM_TIMER = $0113;
InstanceCount = 313;
type
TWndMethod = procedure(var Message: TMessage) of object;
type
PObjectInstance = ^TObjectInstance;
TObjectInstance = packed record
Code: Byte;
Offset: Integer;
case Integer of
0: (Next: PObjectInstance);
1: (Method: TWndMethod);
end;
type
PInstanceBlock = ^TInstanceBlock;
TInstanceBlock = packed record
Next: PInstanceBlock;
Code: array[1..2] of Byte;
WndProcPtr: Pointer;
Instances: array[0..InstanceCount] of TObjectInstance;
end;
var
InstBlockList: PInstanceBlock;
InstFreeList: PObjectInstance;
function TExTimer.ProcessMessage(var Msg: TMsg): Boolean;
begin
Result := False;
if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
begin
Result := True;
if Msg.Message <> $0012 then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
end;
procedure TExTimer.ProcessMessages;
var
Msg: TMsg;
begin
while ProcessMessage(Msg) do;
end;
{ Allocate an object instance }
function CalcJmpOffset(Src, Dest: Pointer): Longint;
begin
Result := Longint(Dest) - (Longint(Src) + 5);
end;
function StdWndProc(Window: HWND; Message, WParam: Longint;
LParam: Longint): Longint; stdcall; assembler;
asm
XOR EAX,EAX
PUSH EAX
PUSH LParam
PUSH WParam
PUSH Message
MOV EDX,ESP
MOV EAX,[ECX].Longint[4]
CALL [ECX].Pointer
ADD ESP,12
POP EAX
end;
function MakeObjectInstance(Method: TWndMethod): Pointer;
const
BlockCode: array[1..2] of Byte = (
$59, { POP ECX }
$E9); { JMP StdWndProc }
PageSize = 4096;
var
Block: PInstanceBlock;
Instance: PObjectInstance;
begin
if InstFreeList = nil then
begin
Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
Block^.Next := InstBlockList;
Move(BlockCode, Block^.Code, SizeOf(BlockCode));
Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
Instance := @Block^.Instances;
repeat
Instance^.Code := $E8; { CALL NEAR PTR Offset }
Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
Instance^.Next := InstFreeList;
InstFreeList := Instance;
Inc(Longint(Instance), SizeOf(TObjectInstance));
until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
InstBlockList := Block;
end;
Result := InstFreeList;
Instance := InstFreeList;
InstFreeList := Instance^.Next;
Instance^.Method := Method;
end;
{ Free an object instance }
procedure FreeObjectInstance(ObjectInstance: Pointer);
begin
if ObjectInstance <> nil then
begin
PObjectInstance(ObjectInstance)^.Next := InstFreeList;
InstFreeList := ObjectInstance;
end;
end;
var
UtilWindowClass: TWndClass = (
style: 0;
lpfnWndProc: @DefWindowProc;
cbClsExtra: 0;
cbWndExtra: 0;
hInstance: 0;
hIcon: 0;
hCursor: 0;
hbrBackground: 0;
lpszMenuName: nil;
lpszClassName: 'TPUtilWindow');
function AllocateHWnd(Method: TWndMethod): HWND;
var
TempClass: TWndClass;
ClassRegistered: Boolean;
begin
UtilWindowClass.hInstance := HInstance;
{$IFDEF PIC}
UtilWindowClass.lpfnWndProc := @DefWindowProc;
{$ENDIF}
ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName,
TempClass);
if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then
begin
if ClassRegistered then
Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance);
Windows.RegisterClass(UtilWindowClass);
end;
Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName,
'', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
if Assigned(Method) then
SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
end;
procedure DeallocateHWnd(Wnd: HWND);
var
Instance: Pointer;
begin
Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
DestroyWindow(Wnd);
if Instance <> @DefWindowProc then FreeObjectInstance(Instance);
end;
{ TExTimer }
Procedure Exception;
Begin
End;
constructor TExTimer.Create;
begin
inherited Create;
FEnabled := True;
FInterval := 1000;
FWindowHandle := AllocateHWnd(WndProc);
end;
destructor TExTimer.Destroy;
begin
FEnabled := False;
UpdateTimer;
DeallocateHWnd(FWindowHandle);
inherited Destroy;
end;
procedure TExTimer.WndProc(var Msg: TMessage);
begin
with Msg do
if Msg = WM_TIMER then
try
Timer;
except
Exception;
end
else
Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
end;
procedure TExTimer.UpdateTimer;
begin
KillTimer(FWindowHandle, 1);
if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
if SeTTimer(FWindowHandle, 1, FInterval, nil) = 0 then
Begin
Exception;
End;
end;
procedure TExTimer.SetEnabled(Value: Boolean);
begin
if Value <> FEnabled then
begin
FEnabled := Value;
UpdateTimer;
end;
end;
procedure TExTimer.SetInterval(Value: Cardinal);
begin
if Value <> FInterval then
begin
FInterval := Value;
UpdateTimer;
end;
end;
procedure TExTimer.SetOnTimer(Value: TNotifyEvent);
begin
FOnTimer := Value;
UpdateTimer;
end;
procedure TExTimer.Timer;
begin
if Assigned(FOnTimer) then FOnTimer;
end;
end.
08/05/2008, 23:25
Timer:Settimer 
Benzer Konular 
