Данная тема уже обсуждалась, но у меня есть своя реализация сабжа. Начиная с Pentium MMX, Intel ввели в процессор счетчик тактов на 64 бита (Присутствует точно и в К6). Для того чтобы посмотреть на его содержание, была введена команда "rdtsc" (подробное описание в интеловской мануале). Эту возможность можно использовать для реализации сабжа.

Поскольку Дельфи не в курсе насчет rdtsc, то пришлось юзать опкод (0F31).

Привожу простенький примерчик юзания, Вы уж извините - немножко кривоват получился, да и ошибка компилятора какая-то вылезла :( (V4 Bld5.104 Upd 2). Кому интересно, поделитесь своими соображениями по этому поводу. Особенно интересует работа в режиме когда меняется частота процессора (Duty Cycle, Standby).

 

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.

Windows is not a real time operating system so it is not really able to reliably achieve high accuracy timing without using a device driver. The best I have been able to get is a few nanoseconds using QueryPerformanceCounter. This is the procedure I use:

 

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;

 

To get improved accuracy do this a little while before using Wait()

 

Code:

var

Start, Finish: Int64;

 

Application.ProcessMessages;

Sleep(10);

QueryPerformanceCounter(Start);

Wait(0);

QueryPerformanceCounter(Finish);

WaitCal := Start - Finish;

 

A trick I have found to increase the reliability of this on my computer is to call Wait like this:

 

Code:

Application.ProcessMessages;

Sleep(0);

DoSomething;

Wait(10);

DoSomethingElse;

 

 

Взято из http://www.lmc-mediaagentur

 


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.

 

 

Незабывайте, чтопогрешности, которыебудетвыдаватьпрограмма-тестербудутиз-затого, чтокакое-товремятратитьсянавызовпроцедуры, циклыит.д. (т.к. тамиспользуютсяпроцедурыDelaySec, MDelay).... НоесливызватьResetCounter, ачерезнекотороевремяGetCounterSec, торезультатбудетточным (собственно, именнотакздесьиизмеряютсяпогрешности)! Иможновызыватьего (GetCounterSec) ещёхоть 10000 раз! ;D
Кстати, запускайтетестертольковполноэкранномрежиме, т.к. программаотключаетмногозадачность Windows, инаэкраневыничегонеувидите (будетвпечатление, чтопрогаповисла).

 

Автор: 7jin

 

Взято из http://forum.sources


 

Авотещёодинспособ (работаеттолькона Pentium иливыше)....

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.

 

 

Автор: 7jin

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:

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

begin

//

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

end;

 

а дальше в программе (например по нажатию кнопки) создаешь Таймер и вешаешь на него созданную процедуру

Code:

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

 

 

Подробности смотри в Help.Hу и в конце убиваешь таймер:

Code:

timeKillEvent(uTimerID);

 

 

И все. Точность этого способа до 1 мсек. минимальный интервал времени можно задавать 1 мсек.

 

Автор: Leonid Tserling

Компонент timer (таймер) служит для отсчета интервалов реального времени. Его свойство interval определяет интервал временив миллисекундах , который должен пройти от включения таймера до наступления события ontimer. Таймер включается при установке значения true в его свойство enabled. Единожды включенный таймер все время будет возбуждать события ontimer до тех пор, пока его свойство enabled не примет значения false.

Следует учесть, что в силу специфики реализации стандартного аппаратного таймера ibm-совместимого компьютера минимальный реально достижимый интервал отсчета времени не может быть меньше 55 мс (этот интервал называется тиком), более того, любой интервал времени, отсчитываемый с помощью таймера, всегда кратен 55 мс. Чтобы убедиться в этом, проведите эксперимент, в котором подсчитывается среднее время между двумя срабатываниями таймера (timer.dpr):

Начните новый проект с пустой формой и положите на нее компонент ttimer.
Установите в свойство enabled таймера значение false.
Напишите такой модуль главной формы (листинг 4):
Листинг 4

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.

 

Необходимость нескольких (maxcount) срабатываний для точного усреднения результата связана с тем, что системные часы обновляются каждые 55 мс. После запуска программы и ввода 1 как требуемого периода срабатывания в редакторе mmoutput вы увидите строку

 Задано 1 ms. Получено 55 ms.

 в которой указывается, какое реальное время разделяет два соседних события ontimer. Если вы установите период таймера в диапазоне от 56 до 110 мс, в строке будет указано 110 ms и т.д. (в силу дискретности обновления системных часов результаты могут несколько отличаться в ту или иную сторону).

 

В ряде практически важных областей применения (при разработке игр, в системах реального времени для управления внешними устройствам и т.п.) интервал 55 мс может оказаться слишком велик. Современный ПК имеет мультимедийный таймер, период срабатывания которого может быть от 1 мс и выше, однако этот таймер не имеет компонентного воплощения, поэтому для доступа к нему приходится использовать функции api.

 

Общая схема его использования такова. Сначала готовится процедура обратного вызова (call back) с заголовком:

Code:

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

Здесь uid — идентификатор события таймера (см. об этом ниже); umsg — не используется; dwuser — произвольное число, передаваемое процедуре в момент срабатывания таймера; dw1, dw2 — не используются.

Запуск таймера реализуется функцией:

 

Code:

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

Здесь udelay — необходимый период срабатывания таймера (в мс); uresolution — разрешение таймера (значение 0 означает, что события срабатывания таймера будут возникать с максимально возможной частотой; в целях снижения нагрузки на систему вы можете увеличить это значение); lptimeproc — адрес процедуры обратного вызова; dwuser — произвольное число, которое передается процедуре обратного вызова и которым программист может распоряжаться по своему усмотрению; fuevent — параметр, управляющий периодичностью возникновения события таймера: time_oneshot (0) — событие возникает только один раз через udelay миллисекунд; time_periodic (1) — события возникают периодически каждые udelay мс. При успешном обращении функция возвращает идентификатор события таймера и 0, если обращение было ошибочным.

 

Таймер останавливается, и связанные с ним системные ресурсы освобождаются функцией:

 

Code:

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

 

Здесь uid — идентификатор события таймера, полученный с помощью timesetevent.

В следующем примере (timer.dpr) иллюстрируется использование мультимедийного таймера (листинг 5).

 

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.

Источник: http://www.delphi.h5