Delphi в Интернет, блог Delphi программистов

Полагаю, что многие, кто сталкивался с проблемой точного отсчёта времени в Delphi, знают, что стандартный компонент Timer со страницы палитры компонентов System не может обеспечить гарантированно точность отсчёта промежутка времени менее 50 мс. Более того,  при работе с этим компонентом частенько случаются "заскоки" при работе в разных ОС. Например, такая проблема с работой компонента рассматривается здесь.  Как же сделать так, чтобы программа отсчитывала время точно?

Не будем изобретать велосипед, а воспользуемся уже имеющимся, хотя и малоосвещенным способом - создадим свой мультимедиа таймер с высокой точностью отсчёта промежутков времени.< ' ' >

Для работы воспользуемся ранее рассмотренным проектом из статьи "Мышометры и им подобные звери". Доработаем проект таким образом, чтобы избавиться от использования стандартного компонента и вместе с тем не нарушить порядок работы программы.

1. Техническая реализация таймера высокой точности.

Вначале уясним, что за программный таймер мы создаем и чем он отличается от компонента Timer, помещенного на форму. А отличается наш таймер, кроме высокой точности, тем, что его не нежно привязывать к окну: при срабатывании стандартного таймера окну, за которым он закреплен, посылается сообщение WM_TIMER. Создаваемый же нами таймер работает по-другому. А теперь приступим к его реализации.

Первое, что вам следует зделать - объявить в секции uses модуь MMSystem. Собственно в нем (модуле) и содержатся все необходимые типы и методы для работы с нашим таймером.

Теперь объявляем переменную:

TimerID : UINT; //идентификатор таймера

Напишем процедуру, вызываемую при срабатывании таймера. Она в принципе уже готова (событие onTimer у компонента Timer на главной форме), но для порядка приведу её здесь с небольшим изменениями - в процедуре дополнительно просчитывается текущая скорость движения мыши по экрану:

procedure TimerProc(uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD) stdcall;
var curPos: TPoint;
delta:real;
begin
GetCursorPos(curPos);
if (curPos.X<>LastPos.X)or(curPos.Y<>LastPos.Y) then
begin
if doUpdate then
begin
delta:=SQRT(sqr(curPos.X-LastPos.X)+sqr(curPos.Y-LastPos.Y));
distance:=distance+delta;
LastDelta:=delta*(GetDeviceCaps(DC, HORZSIZE)/Screen.Width);
LastPos:=curPos;
Form1.label18.Caption:=CurrToStr(distance*GetDeviceCaps(DC, HORZSIZE)/Screen.Width*0.001);
end;
end;
Form1.Label21.Caption:=CurrToStr(LastDelta*10)+' м/с'
end;

Теперь создаем наш програмный таймер:

TimerID:=timeSetEvent(10, timeGetMinPeriod, TimerProc, 0, TIME_CALLBACK_FUNCTION or TIME_PERIODIC);

Создавать таймер можно где угодно, лишь бы он выполнял свои функции. Я разместил создание в событии onClick единственной кнопки приложения :).

В приведенном выше отрывке программы с помощью функции timeSetEvent происходит регистрация и запоминание адреса процедуры TimerProc, вызываемой периодически при срабатывании таймера. При успешном создании таймера функция timeSetEvent возвращает ненулевое значение - идентификатор созданного таймера. Оно может использоваться в дальнейшем для определения, какой именно таймер сработал. Значение, возвращаемое функцией timeSetEvent, также необходимо при удалении таймера:

timeKillEvent(TimerID)

Функция timeKillEvent возвращает целочисленное значение:

• TIMER_NOERROR - если её вызов завершился успешно;
• MMSYSERR_INVALPARAM - если таймера, заданного параметром функции, не существует.

Теперь обратимся вновь к процедуре timeSetEvent. Что же мы там задали:

• 10 - интервал между срабатываниями таймера, мс
• timeGetMinPeriod - точность таймера (см. код функции ниже)
• TimerProc - адрес процедуры, вызываемой при срабатывании таймера;
• 0 - параметр, передаваемый в процедуру обратного вызова;
• TIME_CALLBACK_FUNCTION or TIME_PERIODIC - тип таймера.

Как вы можете заметить, последний параметр функции - это битовая маска. Флаги этой маски задают два аспекта поведения таймера: количество срабатываний и тип действия, которое требуется выполнить при срабатывании таймера.

Количество срабатываний таймера определяется двумя значениями:

• TIMER_ONESHOT - таймер срабатывает один раз. Для таких таймеров вызывать timeKillEvent после срабатывания не нужно.
• TIMER_PERIODIC - таймер срабатывает периодически через заданные промежутки времени.

Тип действия, выполняемого таймером, задается при помощи следующих констант:

• TIME_CALLBACK_FUNCTION - при срабатывании таймера вызывается процудура, адрес которой был передан третьим параметром;
• TIME_CALLBACK_EVENT_SET - вызывает SetEvent для объекта синхронизации "событие", дескриптор которого передан третьим параметром;
• TIME_CALLBACK_EVENT_PULSE - вызывает PulseEvent для объекта синхронизации "событие", дескриптор которого передан третьим параметром;

Т.к. объекты синхронизации нас не интересуют, то рассматривать их в этой статье смысла нет. Вместо этого ещё раз повторим действия, которые необходимо выполнить при работе с программным таймером. Это:

1. Определяем действия, которые необходимо выполнить при срабатывании таймера и создаем процедуру, адрес которой будем передавать третьим параметром;
2. Создаем таймер и регистрируем процедуру с помощью функции timeSetEvent
3. После того как таймер отработал "убиваем" его с помощью функции timeKillEvent

Осталось рассмотреть дополнительные функции по работе с таймером.

2. Дополнительные процедуры по работе с программными таймерами.

Во-первых рассмотрим процедуру timeGetMinPeriod, которая определяет минимальный период таймера. Выглядит она следующим образом:

function timeGetMinPeriod(): DWORD;
var  time: TTimeCaps;
begin
timeGetDevCaps(Addr(time), SizeOf(time));
timeGetMinPeriod := time.wPeriodMin;
end;

Соответственно, максимальный период таймера будет определяться следующим образом:

function timeGetMaxPeriod(): Cardinal;
var time: TTimeCaps;
begin
timeGetDevCaps(Addr(time), SizeOf(time));
timeGetMaxPeriod := time.wPeriodMax;
end;

Чтобы установить новый период срабатывания таймера, перед началом измерения  необходимо выполнить функцию:

function timeSetTimerPeriod(period: Cardinal): Boolean;
begin
if timeBeginPeriod(period) = TIMERR_NOERROR then
begin
//Сохраним значение для восстановления состояния таймера
lastPeriod := period;
timeSetTimerPeriod := True;
end
else
//Неудача
timeSetTimerPeriod := False;
end;

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

function timeRestoreTimerPeriod(): Boolean;
begin
if timeEndPeriod(lastPeriod) = TIMERR_NOERROR then
timeRestoreTimerPeriod := True
else
timeRestoreTimerPeriod := False;
end;

Теперь Вы можете смело доработать программу, убрав с главной форму компонент Timer и заменив его на новый программный. Кроме того, при небольшой доработке программы Вы сможете узнать не только расстояние пройденное мышкой по экрану, но и (что немаловажно для неискушенных пользователей "Мышометров") скорость движения мыши по экрану.

В этой статье я рассмотрел всего лишь один из возможных способов отсчёт промежутков времени с высокой точностью. Если же Вам необходимо засечь время, необходимое для выполнения какого-либо длительного процесса в программе, то тут Вам на помощь прийдут и другие способы, например использование "тиков" и пр. Но это уже совсем другая история ;)

Мой блог находят по следующим фразам

• запись структуры в xml
• кодировка файла delphi
• GetKeyboardLayout delphi 2010
• synapse ansi
• AlphaControls
• JVCL +lazarus
• Delphi в Internet

Делись!	Загружай!	Плюсуй!
	Отправить PDF на

Комментарии (12)

• Витя пишет:
  03 Окт 2009 в 11:00 дп

  Очень ценная штука.

• Karp13 пишет:
  03 Окт 2009 в 7:27 пп

  Я тебя люблю, Чувак!! ^_^
  Очень классная статья!! Кок раз то что искал!!))

• WOWan пишет:
  26 Мар 2010 в 1:43 пп

  Статья — супер!!!

  если еще микросекунды реализовать…

• Евгений пишет:
  30 Ноя 2010 в 11:13 пп

  Всё это очень замечательно, но вылетает ошибка по поводу нехватки памяти или что-то в этом духе. Пробовал на разных компах и на мощном такая же беда. Что делать как быть?

• Vlad пишет:
  30 Ноя 2010 в 11:20 пп

  Ошибка Access Violation? Точный код с ошибкой в студию — будем разбираться.

• Евгений пишет:
  30 Ноя 2010 в 11:48 пп

  Access violation at address 00401BFC in module ‘Project1.exe’.Write of addres 00003131
  А вот ещё одна… Error creating window device context — вылетает вылетает несколько штук если программа работает более десяти минут(замечена с обычным таймером)… тоже проверял на разных компах.

• Vlad пишет:
  01 Дек 2010 в 12:19 дп

  А код программы-то где? :) Про AV я и так понял, что она вылетает. Скиньте код вашего таймера, желательно весь

• Евгений пишет:
  01 Дек 2010 в 12:35 дп
  unit Unit1;

  interface

  uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, MMSystem, StdCtrls, ExtCtrls;

  type
  TForm1 = class(TForm)
  Label1: TLabel;
  Button1: TButton;
  Button2: TButton;
  Label2: TLabel;
  Timer1: TTimer;
  Button3: TButton;
  Button4: TButton;
  procedure Button1Click(Sender: TObject);
  procedure Button2Click(Sender: TObject);
  procedure Timer1Timer(Sender: TObject);
  procedure Button3Click(Sender: TObject);
  procedure Button4Click(Sender: TObject);
  private
  { Private declarations }
  public

  { Public declarations }
  end;

  var
  Form1: TForm1;
  TimerID : UINT;
  LastPos: TPoint;
  lastPeriod:Cardinal;
  LastDelta:Real;
  doUpdate: boolean;
  distance: single;
  DC: HDC;
  curPos: TPoint;
  delta:real;

  a:integer;
  b:TPoint;

  implementation

  {$R *.dfm}

  function timeGetMinPeriod(): DWORD;
  var
  time: TTimeCaps;
  begin
  timeGetDevCaps(Addr(time), SizeOf(time));
  timeGetMinPeriod := time.wPeriodMin;
  end;

  //Соответственно, максимальный период таймера будет определяться следующим образом:
  function timeGetMaxPeriod(): Cardinal;
  var
  time: TTimeCaps;
  begin
  timeGetDevCaps(Addr(time), SizeOf(time));
  timeGetMaxPeriod := time.wPeriodMax;
  end;

  //Чтобы установить новый период срабатывания таймера, перед началом измерения необходимо выполнить функцию:
  function timeSetTimerPeriod(period: Cardinal): Boolean;
  begin
  if timeBeginPeriod(period) = TIMERR_NOERROR then
  begin
  //Сохраним значение для восстановления состояния таймера
  lastPeriod := period;
  timeSetTimerPeriod := True;
  end
  else
  //Неудача
  timeSetTimerPeriod := False;
  end;

  //Ну, и наконец, для восстановления периода таймера необходимо обязательно выполнить функцию:
  function timeRestoreTimerPeriod(): Boolean;
  begin
  if timeEndPeriod(lastPeriod) = TIMERR_NOERROR then
  timeRestoreTimerPeriod := True
  else
  timeRestoreTimerPeriod := False;
  end;

  procedure TForm1.Button2Click(Sender: TObject);
  begin
  GetCursorPos(LastPos);
  doUpdate:=true;
  DC:=GetDC(Handle);
  end;

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

  GetCursorPos(curPos);
  if curPos.X&lt;&gt;LastPos.X then
  begin
  if doUpdate then
  begin
  delta:=curPos.X-LastPos.X;
  distance:=distance+delta;
  LastPos:=curPos;
  Form1.label1.Caption:=CurrToStr(distance);
  Form1.label2.Caption:=CurrToStr(delta);
  end;
  end;
  end;

  procedure TForm1.Button1Click(Sender: TObject);
  begin
  TimerID:=timeSetEvent(10, timeGetMinPeriod, TimerProc, 0, TIME_CALLBACK_FUNCTION or TIME_PERIODIC);
  end;

  procedure TForm1.Timer1Timer(Sender: TObject);
  var curPos: TPoint;
  delta:real;
  DC: HDC;
  begin
  DC:=GetDC(Handle);
  GetCursorPos(curPos);
  if (curPos.X&lt;&gt;LastPos.X)or(curPos.Y&lt;&gt;LastPos.Y) then
  begin
  if doUpdate then
  begin
  delta:=Sqrt(sqr(curPos.X-LastPos.X)+sqr(curPos.Y-LastPos.Y));
  distance:=distance+delta;
  LastPos:=curPos;

  label1.Caption:=CurrToStr(distance*200/Screen.Width*0.001);
  end;
  end;
  end;

  procedure TForm1.Button3Click(Sender: TObject);
  begin
  Timer1.Enabled:=true;
  end;

  procedure TForm1.Button4Click(Sender: TObject);
  begin
  distance:=0;
  end;

  end.

• Евгений пишет:
  01 Дек 2010 в 12:43 дп

  ой, я теги честно поставил

• Евгений пишет:
  02 Дек 2010 в 11:57 пп

  Пожалуйста, давайте всё же разберёмся что тут не так… очень нужна программа такая.

• Vlad пишет:
  03 Дек 2010 в 4:50 пп

  Да конечно разберемся :) Просто неделя-то рабочая вот времени особенно и нету на Delphi. Сегодня-завтра гляну ваш листинг и отпишусь

• Vlad пишет:
  04 Дек 2010 в 6:30 пп

  Евгений, воспроизвел ваш листинг в точности как вы его здесь представили. ждал минут 10 — никаких AV не было вообще. Сбросьте (если это возможно) мне на email (vlad383@mail.ru) весь проект целиком

Ваш ответ