delphi实现的高精度Timer

一般来说，实现高精度timer的做法都是用winmm.dll中的相关api实现，但本人在使用时发现这样的做法有问题，如果在ontimer事件里释放某一TWinControl实例（例如一个窗口）就会出现System error :5 访问拒绝的错误，原因未知。

本人找了一个笨办法，只要在ontimer事件里通过一个TTimer来触发事件就没问题了，下面是我修改后的Timer，使用的时候需要把EventProtect设置成True就可以了。
组件在jacky_shen的TMMTimer 1.1版的基础上修改而来，在此向他表示感谢。

原链接：http://topic.csdn.net/t/20031215/10/2564070.html
 

unit uAsmTimer;

interface

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

type
  TMMTimerKind = (tkLoop(*循环*), tkOneShot(*只执行一次*));

  //高精度Timer
  THRTimer = class(TComponent)
  private
    { Private   declarations }
    fStdTimer : TTimer;
    fTimerId: DWORD;
    fEnabled: Boolean;
    fPeriodMax: DWORD;
    fPeriodMin: DWORD;
    fInterval: DWORD;
    fTimeCaps: TTimeCaps;
    fResolution: DWORD;
    fOnTimer: TNotifyEvent;
    fIndex: Integer;
    fTimerKind: TMMTimerKind;
    fEventProtect: boolean;

    procedure StartTimer;
    procedure TerminateTimer;
    procedure setEnabled(Value: Boolean);
    procedure SetInterval(Value: DWORD);
    procedure SetResolution(Value: DWORD);
    function read: TMMTimerKind;
    procedure onEventProtectTimer(Sender : TObject);
  protected
    { Protected declarations }
    procedure Timer; dynamic;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    class function getTicketCount: Cardinal;
  published
    { Published declarations }
    property Enabled: Boolean read fEnabled write setEnabled default False;
    property Interval: DWORD read fInterval write SetInterval default 1000;
    property Resolution: DWORD read fResolution write SetResolution;
    property OnTimer: TNotifyEvent read fOnTimer write fOnTimer;
    property TimerKind : TMMTimerKind read fTimerKind write fTimerKind default tkLoop;
    property EventProtect : boolean read fEventProtect write fEventProtect default False;
  end;

implementation

{ THRTimer }

type
  TPointerList = array of Pointer;

var
  // 用于保存创建的计时器指针
  gMMTimerList: TPointerList;
  gMMTimerListCount: DWORD;

procedure TimeProc(uID: DWORD; uMsg: DWORD; dwUser: DWORD; dw1: DWORD; dw2: DWORD); stdcall;
begin
  if gMMTimerList <> nil then
    THRTimer(gMMTimerList[dwUser]).Timer;
end;

constructor THRTimer.Create(AOwner: TComponent);
begin
  inherited;
  fStdTimer := TTimer.Create(Self);
  fStdTimer.Enabled := false;
  fStdTimer.Interval := 100;

  fEventProtect := False;
  fEnabled := False;
  fInterval := 1000;
  Inc(gMMTimerListCount);
  SetLength(gMMTimerList, gMMTimerListCount);
  //   记录索引
  fIndex := gMMTimerListCount - 1;
  //   保存新计时器指针
  gMMTimerList[fIndex] := Self;
  if timeGetDevCaps(@fTimeCaps, SizeOf(TimeCaps)) = TIMERR_NOERROR then
  begin
    fPeriodMax := fTimeCaps.wPeriodMax;
    fPeriodMin := fTimeCaps.wPeriodMin;
    fResolution := fPeriodMin;
  end;
end;

destructor THRTimer.Destroy;
begin
  if fEnabled then TerminateTimer;
  inherited;
end;

class function THRTimer.getTicketCount: Cardinal;
begin
  Result := timeGetTime;
end;

procedure THRTimer.onEventProtectTimer(Sender: TObject);
begin
  TTimer(Sender).Enabled := False;
  if Assigned(fOnTimer) then
    fOnTimer(Self);
end;

function THRTimer.read: TMMTimerKind;
begin
  Result := fTimerKind;
end;

procedure THRTimer.setEnabled(Value: Boolean);
begin
  if Value <> fEnabled then
  begin
    fEnabled := Value;
    if Value then
      StartTimer
    else
      TerminateTimer;
  end;
end;

procedure THRTimer.SetInterval(Value: DWORD);
begin
  if Value <> fInterval then
  begin
    //   设定间隔时间
    fInterval := Value;
    if fEnabled then
    begin
      //   删除旧的定时器
      TerminateTimer;
      //   重新创建定时器
      StartTimer;
    end;
  end;
end;

procedure THRTimer.SetResolution(Value: DWORD);
begin
  if Value <> fResolution then
    if Value in [fPeriodMin..fPeriodMax] then
    begin
      TerminateTimer;
      fResolution := Value;
      StartTimer;
    end;
end;

procedure THRTimer.StartTimer;
begin
  if not (csDesigning in ComponentState) then
  begin
    timeBeginPeriod(fResolution);
    if fTimerKind = tkLoop then
      fTimerId := timeSetEvent(fInterval, fResolution, @TimeProc, fIndex, TIME_PERIODIC)
    else if fTimerKind = tkOneShot then
      fTimerId := timeSetEvent(fInterval, fResolution, @TimeProc, fIndex, TIME_ONESHOT)
    else
      raise Exception.CreateFmt('%s.TimerKind failure', [className]);
  end;
end;

procedure THRTimer.TerminateTimer;
begin
  if fTimerId <> 0 then
  begin
    timeKillEvent(fTimerId);
    timeEndPeriod(fResolution);
  end;
end;

procedure THRTimer.Timer;
begin
  if (csDestroying in Self.ComponentState) then
  begin
    Self.fStdTimer.OnTimer := nil;
    Self.fStdTimer.Enabled := False;
    Self.Enabled := False;
    Exit;
  end;

  if fEventProtect then
  begin
    fStdTimer.OnTimer := onEventProtectTimer;
    fStdTimer.Enabled := True;
  end
  else if Assigned(fOnTimer) then
    fOnTimer(Self);
end;

initialization

finalization
  gMMTimerList := nil;

end.