Code:

procedure FNTimeCallBack(uTimerID, uMessage: UINT;dwUser, dw1, dw2: DWORD);stdcall;

begin

//

// Тело процедуры.

end;

Code:

uTimerID:=timeSetEvent(10,500,@FNTimeCallBack,100,TIME_PERIODIC);

Code:

timeKillEvent(uTimerID);

Code:

unit unit1;

interface

uses

windows, messages, sysutils, classes, graphics, controls, forms,

dialogs, stdctrls, buttons, extctrls;

type

tfmexample = class(tform)

panel1: tpanel;

bbrun: tbitbtn;

bbclose: tbitbtn;

edinput: tedit;

lboutput: tlabel;

mmoutput: tmemo;

timer1: ttimer;

procedure bbrunclick(sender: tobject);

procedure timer1timer(sender: tobject);

procedure formactivate(sender: tobject);

private

begtime: tdatetime; // Начальное время цикла

counter: integer; // Счетчик цикла

end;

var fmexample: tfmexample;

implementation

{$r *.dfm}

procedure tfmexample.bbrunclick(sender: tobject);

// Запускает таймер. edinput содержит период его срабатывания.

var delay: word;

begin

// Проверяем задание интервала

if edinput.text=''then exit;

try

delay := strtoint(edinput.text);

except

showmessage('Ошибка в записи числа');

edinput.selectall;

edinput.setfocus;

exit

end;

counter := 0; // Сбрасываем счетчик

timer1.interval := delay; // Устанавливаем интервал

begtime := time; // Засекаем время

timer1.enabled := true; // Пускаем таймер

screen.cursor := crhourglass

end;

procedure tfmexample.timer1timer(sender: tobject);

var h, m, s, ms: word; // Переменные для декодирования времени

const maxcount = 55; // Количество срабатываний таймера

begin

counter := counter + 1; // Наращиваем счетчик срабатываний

if counter=maxcount then// Конец цикла?

begin// - Да

timer1.enabled := false; // Останавливаем таймер

// Находим среднее время срабатывания:

decodetime((time-begtime)/maxcount, h, m, s, ms);

mmoutput.lines.add( // Выводим результат

format('Задано %s ms. Получено %d ms.', [edinput.text, ms]));

edinput.text := ''; // Готовим следующий запуск

edinput.setfocus;

screen.cursor := crdefault

end;

end;

procedure tfmexample.formactivate(sender: tobject);

begin

edinput.setfocus

end;

end.

Code:

procedure timeproc(uid, umsg: uint; dwuser, dw1, dw2: dword); stdcall;

Code:

function timesetevent(udelay, uresolution: uint; lptimeproc: pointer; dwuser: dword; fuevent: uint): uint; stdcall; external'winmm.dll';

Code:

function timekillevent(uid: uint): uint; stdcall; external'winmm.dll';

Code:

unit unit1;

interface

uses

windows, messages, sysutils, classes, graphics, controls, forms,

dialogs, stdctrls, buttons, extctrls;

type

tfmexample = class(tform)

panel1: tpanel;

bbrun: tbitbtn;

bbclose: tbitbtn;

edinput: tedit;

lboutput: tlabel;

mmoutput: tmemo;

procedure bbrunclick(sender: tobject);

procedure formactivate(sender: tobject);

end;

var fmexample: tfmexample;

implementation

{$r *.dfm}

// Объявление экспортируемых функций:

function timesetevent(udelay, ureolution: uint; lptimeproc: pointer;

dwuser: dword; fuevent: uint): integer; stdcall; external'winmm';

function timekillevent(uid: uint): integer; stdcall; external'winmm';

// Объявление глобальных переменных

var

ueventid: uint; // Идентификатор события таймера

begtime: tdatetime; // Засекаем время<

counter: integer; // Счетчик повторений

delay: word; // Период срабатывания

procedure proctime(uid, msg: uint; dwuse, dw1, dw2: dword); stdcall;

// Реакция на срабатывание таймера (процедура обратного вызова)

var h, m, s, ms: word; // Переменные для декодирования времени

const maxcount = 55; // Количество повторений

begin

timekillevent(ueventid); // Останавливаем таймер

counter := counter+1; // Наращиваем счетчик

if counter=maxcount then// Конец цикла?

begin// - Да: декодируем время

decodetime((time-begtime)/maxcount, h, m, s, ms);

fmexample.mmoutput.lines.add( // Сообщаем результат

format('Задано %s ms. Получено %d ms',

[fmexample.edinput.text,ms]));

fmexample.edinput.text := ''; // Готовим повторение

fmexample.edinput.setfocus

end

else// - Нет: вновь пускаем таймер

ueventid := timesetevent(delay,0,@proctime,0,1);

end;

procedure tfmexample.bbrunclick(sender: tobject);

// Запускает таймер. edinput содержит требуемый период.

begin

// Проверяем задание периода

if edinput.text=''then exit;

try

delay := strtoint(edinput.text)

except

showmessage('Ошибка ввода числа');

edinput.selectall;

edinput.setfocus;

exit

end;

counter := 0; // Сбрасываем счетчик

begtime := time; // Засекаем время

// Запускаем таймер:

ueventid := timesetevent(delay,0,@proctime,0,1);

if ueventid=0then

showmessage('Ошибка запуска таймера')

end;

procedure tfmexample.formactivate(sender: tobject);

begin

edinput.setfocus

end;

end.

Code:

var

WaitCal: Int64;

procedure Wait(ns: Integer);

var

Counter, Freq, WaitUntil: Int64;

begin

if QueryPerformanceCounter(Counter) then

begin

QueryPerformanceFrequency(Freq);

WaitUntil := Counter + WaitCal + (ns * (Freq div1000000));

while Counter < WaitUntil do

QueryPerformanceCounter(Counter);

end

else

Sleep(ns div1000);

end;

Code:

var

Start, Finish: Int64;

Application.ProcessMessages;

Sleep(10);

QueryPerformanceCounter(Start);

Wait(0);

QueryPerformanceCounter(Finish);

WaitCal := Start - Finish;

Code:

Application.ProcessMessages;

Sleep(0);

DoSomething;

Wait(10);

DoSomethingElse;

Code:

Unit Counter; (* Written by Jin *)

{$O-,F-,S-,N-,R-,Q-}

Interface

Type

tTimerValue = record

Micro: Word; { Счётчик 8253/8254 }

Counter: Longint { Счётчик BIOS }

End;

Const

MicroFreq = 1193181{ $1234DD }; { Частота обновления счётчика Micro (1/сек) }

CounterFreq = MicroFreq / 65536; { Частота обновления счётчика Counter (1/сек) }

MicroInterval = 1 / MicroFreq; { Интервал обновления счётчика Micro (сек) }

CounterInterval = 1 / CounterFreq; { Интервал обновления счётчика Counter (сек) }

Var

BIOSCounter: Longint absolute$0040:$006C;

{ Системный счётчик (обновляется CounterFreq раз/сек, }

{ то есть каждые CounterInterval секунд) }

Procedure InitTimer;

{ Инициализировать таймер (перевести в нужный режим работы). }

{ Эту процедуру необходимо выполнять перед использованием функций }

{ и процедур для получения значения таймера (или счётчика), если }

{ Вы в своей программе изменили режим работы таймера. В противном }

{ случае эта процедура Вам не понадобится, так как она выполняется }

{ в секции инициализации модуля (сразу после запуска программы) ! }

Procedure GetTimerValue(var Timer: tTimerValue);

{ Записать значение таймера в переменную Timer }

Function GetTimerSec: Real;

{ Получить значение таймера в секундах (с точностью до 1 мкс) }

Function GetTimerMillisec: Longint;

{ Получить значение таймера в миллисекундах }

Procedure GetTimerDifference(var Older, Newer, Result: tTimerValue);

{ Записать разницу значений Newer и Older в переменную Result }

Function GetTimerDifSec(var Older, Newer: tTimerValue): Real;

{ Получить разницу значений Newer и Older в секундах }

Function GetTimerDifMillisec(var Older, Newer: tTimerValue): Longint;

{ Получить разницу значений Newer и Older в миллисекундах }

Function ConvTimer2Sec(var Timer: tTimerValue): Real;

{ Получить количество секунд по значению переменной Timer }

Function ConvTimer2Millisec(var Timer: tTimerValue): Longint;

{ Получить количество миллисекунд по значению переменной Timer }

Procedure ConvSec2Timer(Sec: Real; var Timer: tTimerValue);

{ Преобразовать значение секунд Sec типа Real в тип tTimerValue }

Procedure ConvMillisec2Timer(Millisec: Longint; var Timer: tTimerValue);

{ Преобразовать значение миллисекунд Millisec типа Longint в тип tTimerValue }

Procedure ResetCounter;

{ Сбросить счётчик (то есть принять текущее значение таймера за ноль для }

{ процедуры GetCounterValue и функции GetCounterSec) }

Procedure GetCounterValue(var Timer: tTimerValue);

{ Записать значение счётчика в переменную Timer }

Function GetCounterSec: Real;

{ Получить значение секунд счётчика }

Function GetCounterMillisec: Longint;

{ Получить значение миллисекунд счётчика }

Procedure Delay(MS: Word);

{ Задержка MS миллисекунд (1 сек = 1000 мс) }

Procedure DelaySec(Sec: Real);

{ Задержка Sec секунд }

Procedure MDelay(N: Longint);

{ Задержка N * MicroInterval секунд (приближённо N * 0.838095813 мкс). }

{ Если Вам нужны наиболее точные короткие задержки, лучше использовать }

{ эту процедуру, так как она даёт наименьшую погрешность по сравнению }

{ с двумя предыдущими процедурами. }

Implementation

Var Now: tTimerValue;

Var Zero: tTimerValue;

Procedure InitTimer; assembler;

Asm

mov al,34h { Режим 2 таймера 0 }

out 43h,al

xor al,al { 65536 циклов до IRQ }

out 40h,al

out 40h,al

End

Procedure GetTimerValue; assembler;

Asm

cld

xor ax,ax

mov es,ax

mov bx,46Ch { DS:BX = 0000h:046Ch = Таймер BIOS }

cli

mov dx,es:[bx]

mov cx,es:[bx+2]{ CX:DX = Первое значение таймера BIOS }

sti

out 43h,al { Замораживаем таймер 8253/8254 }

cli

mov si,es:[bx]

mov di,es:[bx+2]{ DI:SI = Второе значение таймера BIOS }

in al,40h

mov ah,al

in al,40h

sti

xchg ah,al { AX = Таймер 8253/8254 }

not ax { Обратный отсчёт -> Прямой отсчёт }

cmp dx,si { Первое значение таймера BIOS равно второму значению ? }

je @Ok { Да! Оставляем как есть (CX:DX), иначе... }

or ax,ax { Таймер BIOS изменился после заморозки таймера 8253/8254 (между OUT и CLI) ? }

js @Ok { Да! Оставляем как есть (CX:DX), иначе... }

mov dx,si

mov cx,di { CX:DX = DI:SI, если таймер BIOS изменился между STI и OUT }

@Ok:

les di,Timer

stosw { Low Word }

xchg ax,dx

stosw { Middle Word }

xchg ax,cx

stosw { High Word - Записаны из CX:DX:AX }

End

Function GetTimerSec;

Begin

GetTimerValue(Now);

GetTimerSec := ConvTimer2Sec(Now)

End;

Function GetTimerMillisec;

Begin

GetTimerMillisec := Trunc(GetTimerSec*1000)

End;

Procedure GetTimerDifference; assembler;

Asm

cld

push ds

lds si,Newer

lodsw { Low Word }

xchg cx,ax

lodsw { Middle Word }

xchg dx,ax

lodsw { High Word }

xchg cx,ax { Прочитаны в CX:DX:AX }

lds si,Older

sub ax,[si]

sbb dx,[si+2]

sbb cx,[si+4] { Вычитаем Older из Newer }

les di,Result

stosw { Low Word }

xchg ax,dx

stosw { Middle Word }

xchg ax,cx

stosw { High Word - Записано из CX:DX:AX }

pop ds

End

Function GetTimerDifSec;

Begin

GetTimerDifference(Older, Newer, Now);

GetTimerDifSec := ConvTimer2Sec(Now)

End;

Function GetTimerDifMillisec;

Begin

GetTimerDifMillisec := Trunc(GetTimerDifSec(Older, Newer)*1000)

End;

Function ConvTimer2Sec;

Begin

ConvTimer2Sec := (Timer.Counter*65536 + Timer.Micro) / MicroFreq

End;

Function ConvTimer2Millisec;

Begin

ConvTimer2Millisec := Trunc(ConvTimer2Sec(Timer)*1000)

End;

Procedure ConvSec2Timer;

Begin

Timer.Counter := Trunc(Sec * CounterFreq);

Timer.Micro := Trunc(Sec * MicroFreq) mod65536

End;

Procedure ConvMillisec2Timer;

Begin

Timer.Counter := Trunc(Millisec/1000 * CounterFreq);

Timer.Micro := Trunc(Millisec/1000 * MicroFreq) mod65536

End;

Procedure ResetCounter;

Begin

GetTimerValue(Zero)

End;

Procedure GetCounterValue;

Begin

GetTimerValue(Timer);

GetTimerDifference(Zero, Timer, Timer)

End;

Function GetCounterSec;

Begin

GetTimerValue(Now);

GetTimerDifference(Zero, Now, Now);

GetCounterSec := ConvTimer2Sec(Now)

End;

Function GetCounterMillisec;

Begin

GetCounterMillisec := Trunc(GetCounterSec*1000)

End;

Procedure Delay;

Var Zero: Longint;

Begin

If MS <= 0then Exit;

Zero := GetTimerMillisec;

Repeat

Until GetTimerMillisec-Zero >= MS

End;

Procedure DelaySec;

Var Zero: Real;

Begin

If Sec <= 0then Exit;

Zero := GetTimerSec;

Repeat

Until GetTimerSec-Zero >= Sec

End;

Procedure MDelay;

Label Check;

Var Zero: tTimerValue;

Begin

If N <= 0then Exit;

GetTimerValue(Zero);

Check:

GetTimerValue(Now);

GetTimerDifference(Zero, Now, Now);

Asm

mov ax,word ptr Now

mov dx,word ptr Now+2{ DX:AX - Прошедшее время }

{ mov cx,word ptr Now+4

or cx,cx

jnz @Exit}

cmp dx,word ptr N+2{ Проверяем старшие слова }

jb Check

cmp ax,word ptr N { Проверяем младшие слова }

jb Check

@Exit:

EndEnd;

Begin

InitTimer

End.

Code:

Uses Counter;

Var

Ans: Char;

i: Longint;

Sec: Real;

Begin

Asm

mov ah,0Dh

int 21h { Сбрасываем кэш }

mov ax,1681h

int 2Fh { Запрещаем Windows Task Switch }

End

Write('Без задержки...');

ResetCounter;

Sec := GetCounterSec;

WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');

Write('1000 раз холостой цикл...');

ResetCounter;

For i := 1to1000do ;

Sec := GetCounterSec;

WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');

Write('1000 раз по 0 сек...');

ResetCounter;

For i := 1to1000do

DelaySec(0);

Sec := GetCounterSec;

WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');

WriteLn('-------------------------------------------------');

Write('1 раз 1 сек...');

ResetCounter;

DelaySec(1);

Sec := GetCounterSec;

WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');

Write('1000 раз по 0.001 сек...');

ResetCounter;

For i := 1to1000do

DelaySec(0.001);

Sec := GetCounterSec;

WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');

Write('10000 раз по 0.0001 сек...');

ResetCounter;

For i := 1to10000do

DelaySec(0.0001);

Sec := GetCounterSec;

WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');

Write('100000 раз по 0.00001 сек...');

ResetCounter;

For i := 1to100000do

DelaySec(0.00001);

Sec := GetCounterSec;

WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');

Write('119318 раз по 1/119318.1 сек...');

ResetCounter;

For i := 1to119318do

MDelay(10);

Sec := GetCounterSec;

WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');

WriteLn('-------------------------------------------------');

Write('Запускать тесты по микросекундам (м.б. очень долгими) [Y/N] ? : ');

Asm

@Repeat:

xor ah,ah

int 16h

or al,20h

cmp al,'y'

je @Ok

cmp al,'n'

jne @Repeat

@Ok:

mov Ans,al

End

WriteLn(Ans);

If Ans = 'y'then

Begin

Write('1000000 раз по 0.000001 сек...');

ResetCounter;

For i := 1to1000000do

DelaySec(0.000001);

Sec := GetCounterSec;

WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');

Write('1193181 раз по 1/1193181 сек...');

ResetCounter;

For i := 1to1193181do

MDelay(1);

Sec := GetCounterSec;

WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек')

End;

Asm

mov ax,1682h

int 2Fh { Разрешаем Windows Task Switch }

EndEnd.

Code:

Unit TSCDelay; (* Работает только на Pentium (и то не всегда ;) *)

{$O-,F-,G+,S-,R-}

Interface

Var

CPUClock: Longint; { Тактовая частота процессора (гц) }

Procedure CalcCPUClock;

{ Вычислить тактовую частоту процессора и записать в переменную CPUClock. }

Procedure MDelay(N: Longint);

{ Производит задержку в N микросекунд. Задержки более 4294967296/CPUClock }

{ (на 300-м ~ 14) секунд будут работать неправильно из-за переполнения!!! }

{ Перед использованием это процедуры необходимо установить правильное }

{ значение переменной CPUClock. Это можно сделать либо вручную, либо }

{ выполнив процедуру CalcCPUClock. }

Procedure TDelay(N: Longint);

{ Производит задержку в N тактов процессора }

Implementation

Uses Dos;

Var

SaveInt08: Pointer;

Stage: Byte;

Procedure SpeedCounter; far; assembler; { Наш IRQ 0 }

Asm

push ax

push ds

mov ax,seg @Data

mov ds,ax

inc Stage { Прибавляем к Stage единицу }

mov al,20h

out 20h,al { Посылаем сигнал "конец IRQ" }

pop ds

pop ax

iret { Выходим }

End

Procedure CalcCPUClock;

Begin

Asm

mov ah,0Dh

int 21h { Сбрасываем кэш }

mov ax,1681h

int 2Fh { Отключаем Windows Task Switch }

in al,0A1h { Маски IRQ 8-15 }

mov ah,al

in al,21h { Маски IRQ 0-7 }

push ax { Сохраняем маски }

mov al,0FEh

out 21h,al { Запрещаем IRQ 1-7 (нулевой нам нужен) }

inc ax

out 0A1h,al { Запрещаем IRQ 8-15 }

mov al,36h

out 43h,al { Устанавливаем нормальный режим работы таймера }

xor al,al

out 40h,al

out 40h,al { 65536 циклов до IRQ 0 }

mov Stage,0{ Готовимся к началу отсчёта }

End

GetIntVec(8, SaveInt08); { Сохраняем старый IRQ 0 }

SetIntVec(8, @SpeedCounter); { Устанавливаем свой IRQ 0 }

Asm

@1:cmp Stage,1

jne @1{ Цикл до первого IRQ 0 }

db 0Fh,31h { RDTSC }

db 66h; xchg cx,ax { Запоминаем значение счётчика }

@2:cmp Stage,2

jne @2{ Цикл до второго IRQ 0 }

db 0Fh,31h { RDTSC }

db 66h; sub ax,cx { Вычитаем из текущего значение счётчика запомненное }

db 66h,0B9h; dd 1234DDh { mov ecx,1234DDh }

db 66h; mul cx { Умножаем значение на 1193181 }

db 66h,0Fh,0ACh,0D0h,10h { shrd eax,edx,16 - делим на 65536 }

db 66h; mov word ptr CPUClock,ax { Записываем результат в CPUClock }

pop ax

out 21h,al { Восстанавливаем маску IRQ 0-7 }

mov al,ah

out 0A1h,al { Восстанавливаем маску IRQ 8-15 }

End

SetIntVec(8, SaveInt08); { Восстанавливаем старый IRQ 0 }

Asm

mov ax,1682h

int 2Fh { Включаем Windows Task Switch }

EndEnd;

Procedure MDelay; assembler;

Asm

db 0Fh,31h { RDTSC }

db 66h; push ax

db 66h; push dx { Сохраняем счётчик в стеке }

db 66h; mov ax,word ptr N

db 66h; mov cx,word ptr CPUClock

db 66h; mul cx { Умножаем N на CPUClock }

db 66h,0B9h; dd 1000000{ mov ecx,1000000 }

db 66h; div cx { Затем делим на 1000000 }

db 66h; xchg si,ax { Сохраняем значение в ESI }

db 66h; pop cx

db 66h; pop bx { Восстанавливаем значение счётчика в ECX:EBX }

@:db 0Fh,31h { RDTSC }

db 66h; sub ax,bx

db 66h; sbb dx,cx { Вычитаем из текущего счётчика ECX:EBX }

db 66h; or dx,dx { Старшая часть разницы д.б. всегда 0, проверяем это }

jnz @Exit { Нет - выходим! }

db 66h; cmp ax,si { Проверяем - прошло ли столько, сколько нам надо }

jb @ { Нет - ждём ещё }

@Exit:

End

Procedure TDelay; assembler;

Asm

db 0Fh,31h { RDTSC }

db 66h; mov bx,ax

db 66h; mov cx,dx { Сохраняем счётчик в ECX:EBX }

@:db 0Fh,31h { RDTSC }

db 66h; sub ax,bx

db 66h; sbb dx,cx { Вычитаем из текущего счётчика ECX:EBX }

db 66h; or dx,dx { Старшая часть разницы д.б. всегда 0, проверяем это }

jnz @Exit { Нет - выходим! }

db 66h; cmp ax,word ptr N { Проверяем - прошло ли столько, сколько нам надо }

jb @ { Нет - ждём ещё }

@Exit:

End

End.

Code:

Uses TSCDelay;

Var N: Longint;

Begin

CalcCPUClock;

WriteLn('Тактовая частота процессора: ', CPUClock/1000000: 0: 3,' МГц');

Write('Введите количество микросекунд (не более ', 4294967296.0/CPUClock: 0: 3, ' млн): ');

ReadLn(N);

Write('Задержка...');

MDelay(N);

WriteLn(' всё!')

End.

Code:

procedure Delay(dwMilliseconds: Longint);

var

iStart, iStop: DWORD;

begin

iStart := GetTickCount;

repeat

iStop := GetTickCount;

Application.ProcessMessages;

until (iStop - iStart) >= dwMilliseconds;

end;

Code:

procedure Delay(dwMilliseconds: Longint);

{©Drkb v.3(2007): www.drkb, 

®Vit (Vitaly Nevzorov) - nevzorov}

var

iStart, iStop: DWORD;

begin

iStart := GetTickCount;

repeat

iStop := GetTickCount;

sleep(10);

Application.ProcessMessages;

until (iStop - iStart) >= dwMilliseconds;

end;

Code:

procedure Delay(msecs: Longint);

var

targettime: Longint;

Msg: TMsg;

begin

targettime := GetTickCount + msecs;

while targettime > GetTickCount do

if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then

begin

If Msg.message = WM_QUIT Then

begin

PostQuitMessage(msg.wparam);

Break;

end;

TranslateMessage(Msg);

DispatchMessage(Msg);

end;

end;

{

Note:

The elapsed time is stored as a DWORD value.

Therefore, the time will wrap around to zero if the system is

run continuously for 49.7 days.

}

Code:

{

The Sleep function suspends the execution of the current

thread for a specified interval.

}

Sleep(dwMilliseconds: Word);

Code:

Procedure Delay (IntervalinSeconds:integer);

var i:integer;

{©Drkb v.3(2007): www.drkb, 

®Vit (Vitaly Nevzorov) - nevzorov}

begin

For i:=0to IntervalinSeconds*100do

begin

sleep(10);

Application.ProcessMessages;

end;

end;

Code:

var Canceled:boolean; // должна быть объявлена как глобальная переменная модуля

.....

Function Delay (IntervalinSeconds:integer):boolean; //возвращает true если отработала не прерываясь

{©Drkb v.3(2007): www.drkb, 

(Vitaly Nevzorov) - Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра.}var i:integer;

begin

Canceled:=false;

For i:=0to IntervalinSeconds*100do

begin

sleep(10);

Application.ProcessMessages;

if Canceled then break;

end;

Result:=not Canceled;

end;

........

Procedure TForm1.onButton1Click(Sender:TObject);

begin

Canceled:=true;

end;

Code:

{

Including the Sleep in the loop prevents the app from hogging

100% of the CPU for doing practically nothing but running around the loop.

}

procedure PauseFunc(delay: DWORD);

var

lTicks: DWORD;

begin

lTicks := GetTickCount + delay;

repeat

Sleep(100);

Application.ProcessMessages;

until (lTicks <= GetTickCount) or Application.Terminated;

end;

Code:

procedure Delay(Milliseconds: Integer);

{by Hagen Reddmann}

var

Tick: DWord;

Event: THandle;

begin

Event := CreateEvent(nil, False, False, nil);

try

Tick := GetTickCount + DWord(Milliseconds);

while (Milliseconds > 0) and

(MsgWaitForMultipleObjects(1, Event, False, Milliseconds, QS_ALLINPUT) <> WAIT_TIMEOUT) do

begin

Application.ProcessMessages;

Milliseconds := Tick - GetTickcount;

end;

finally

CloseHandle(Event);

end;

end;

Code:

{ **** UBPFD *********** by kladovka ****

>> Класс-оболочка для объекта синхронизации 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: Алексей Вуколов

********************************************** }

unit wtimer;

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; constName : string );

destructor Destroy; override;

procedure Start;

procedure Stop;

function Wait( Timeout : longint ) : 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; constName: string);

var

pName : PChar;

begin

inherited Create;

ifName = ''then pName := nilelse

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 = 0then

begin

DateTimeToSystemTime( FDueTime, SysTime );

SystemTimeToFileTime( SysTime, LocalTime );

LocalFileTimeToFileTime( LocalTime, UTCTime );

endelse

Value := FLongTime;

SetWaitableTimer( FHandle, Value, FPeriod, nil, nil, false );

end;

procedure TWaitableTimer.Stop;

begin

CancelWaitableTimer( FHandle );

end;

function TWaitableTimer.Wait(Timeout: Integer): 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.

Code:

var

Timer : TWaitableTimer;

....

begin

Timer := TWaitableTimer.Create(false, nil, '');

Timer.Time := Now + 1; //завтра в это же время

Timer.Period := 60 * 1000; //Интервал в 1 минуту

Timer.Start; //запуск таймера

....

Code:

// (C) 1999 ISV

unit Unit1;interfaceuses Windows, Messages, SysUtils, Classes, Graphics,

Controls, Forms,Dialogs, StdCtrls, Buttons, ExtCtrls;

type TForm1 = class(TForm)

Label1: TLabel;

Timer1: TTimer;

Label2: TLabel;

Label3: TLabel;

Button1: TButton;

Button2: TButton;

Label4: TLabel;

procedure Timer1Timer(Sender: TObject);

procedure FormActivate(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

Counter:integer;

//Счетчик срабатывания таймера

Start:int64;

//Начало роботы

Previous:int64;

//Предыдущее значение

PStart,PStop:int64;

//Для примера выч. времени

CurRate:integer;

//Текущая частота проца

function GetCPUClick:int64;

function GetTime(Start,Stop:int64):double;

end;

var Form1: TForm1;implementation{$R *.DFM}

// Функция работает на пнях ММХ или выше а

// также проверялась на К6

function TForm1.GetCPUClick:int64;

begin

asm db 0fh,31h

// Опкод для команды rdtsc mov dword ptr result,eax mov dword ptr result[4],edx

end;

// Не смешно :(. Без ?той штуки

// Компайлер выдает Internal error C1079

Result:=Result;

end;

// Время в секундах между старт и стоп

function TForm1.GetTime(Start,Stop:int64):double;

begin

try result:=(Stop-Start)/CurRate except result:=0;

end;

end;

// Обработчик таймера считает текущую частоту, выводит ее, а также

// усредненную частоту, текущий такт с момента старта процессора.

// При постоянной частоте процессора желательно интервал братьпобольше

// 1-5с для точного прощета частоты процессора.

procedure TForm1.Timer1Timer(Sender: TObject);

var i:int64;

begin

i:=GetCPUClick;

if Counter=0then Start:=i else

begin

Label2.Caption:=Format('Частота общая:%2f',[(i-Start)/(Counter*Timer1.Interval*1000)]);

Label3.Caption:=Format('Частота текущая:%2f',[(i-Previous)/(Timer1.Interval*1000)]);

CurRate:=Round(((i-Previous)*1000)/(Timer1.Interval));

end;

Label1.Cap примера

procedure TForm1.Button1Click(Sender: TObject);

begin

PStart:=GetCPUClick;

end;

// Останавливаем отсчет времени и показуем соко

// прошло секунд

procedure TForm1.Button2Click(Sender: TObject);

begin

PStop:=GetCPUClick;

Label4.Caption:=Format!

('Время между нажатиями:%gсек',[GetTime(PStart,PStop)])

end;

end.