{   Мультимедиа-таймер - регулярный или однократный вызов процедуры
  через указанный интервал времени.
    Вызов напрямую в другом витке, а не через WM_OnTimer.
}
{---------------------------------------------------------------------------
The control program for mass-spectrometer MI1201-AGM
(c) Copyright	 Aleksandrov O.E., 2001

   Molecular Physics department, USTU, Ekaterinsburg, K-2, 620002, RUSSIA
   phone 75-47-15
   E-mail: aleks@dpt.ustu.ru

Программа управления масс-спектрометром МИ1201-АГМ
(c) Собственность     Александрова О.Е., 2001

   620002, Екатеринбург, К-2, УГТУ, Кафедра молекулярной физики
   тел. 75-47-15
   E-mail: aleks@dpt.ustu.ru
----------------------------------------------------------------------------}
unit MMTimer;

{$R-,H-,X+}
{$STACKFRAMES OFF}

interface

uses Classes, Windows, MmSystem;

type
  TMMTimerType=(ttOnce, ttPeriodic, ttPeriodicEx);
  TMMTFlag=(fRunning, {fEntered,} fDoNotStopOnException, fTerminated, fFPUReset);
  TMMTFlags=set of TMMTFlag;
  TMMTimerPar=(mmpParsAvailable, mmpMinREsolution, mmpMaxResolution);

  TMMTimer = class(TObject)
  private
    prTimerID:   uint;
    prTimerType: TMMTimerType;
    prDelay:     uint;
    prResolution:uint;
    prOnTimer:   TNotifyEvent;
    prEnabled:   Boolean;
    prFlags:TMMTFlags;
    procedure UpdateTimer;
    procedure SetEnabled(Value: Boolean);
    function  GetEnabled: Boolean;
    procedure SetInterval(Value: uint);
    procedure SetResolution(Value: uint);
    procedure SetOnTimer(Value: TNotifyEvent);
    procedure TypeSet(Value: TMMTimerType);
    function  EventGet:uint;
    function  ParameterGet(p:TMMTimerPar):uint;
    procedure KillTimer;
  protected
    procedure Timer; dynamic;
    procedure FlagSet(f:TMMTFlag);
    procedure FlagClear(f:TMMTFlag);
  public
    constructor Create;
    destructor  Destroy; override;
    property Parameter[p:TMMTimerPar]:uint read ParameterGet;
    property Enabled:   Boolean      read GetEnabled    write SetEnabled   default True;
    property Flags:     TMMTFlags    read prFlags;
    property Resolution:uint         read prResolution write SetResolution default 5;
    property Interval:  uint         read prDelay      write SetInterval   default 1000;
    property Event:     uint         read EventGet;
    property TimerType: TMMTimerType read prTimerType  write TypeSet       default ttOnce;
    property OnTimer:   TNotifyEvent read prOnTimer    write SetOnTimer;
  end;

implementation


const
  cTimerType2Timer:array[TMMTimerType]of uint =(
    {ttOnce}       TIME_ONESHOT,
    {ttPeriodic}   TIME_PERIODIC,
    {ttPeriodicEx} TIME_ONESHOT
  );

{ TMMTimer }

constructor TMMTimer.Create;
begin
  inherited Create;
  prEnabled := FALSE;
  prTimerType:=ttOnce;
  prDelay:=1000;
  prResolution:=5;
end;

destructor TMMTimer.Destroy;
begin
  KillTimer;
  inherited Destroy;
end;

procedure TimeProc(uID,uMsg:UINT; dwUser,dw1,dw2:DWORD); stdcall;
begin
  TMMTimer(dwUser).Timer;
end;

procedure TMMTimer.KillTimer;
  var ID:uint;
begin
  FlagSet(fTerminated);
  if (prTimerID>0 ) then begin
    id:=prTimerID;
    prTimerID:=0;
    timeKillEvent(id);
    FlagClear(fRunning);
    Exclude(prFlags,fFPUReset);
  end;
end;

procedure TMMTimer.UpdateTimer;
begin
  if Not Assigned(Self) then Exit;
  KillTimer;
  if (Interval>0) and Enabled and Assigned(OnTimer) then begin
    FlagClear(fTerminated);
    prTimerID:=timeSetEvent(Interval, Resolution, TimeProc, DWORD(Self), Event);
    if prTimerID = 0 then begin
      raise EOutOfResources.Create('Ошибка при создании таймера')
    end else begin
      FlagSet(fRunning);
    end;
  end;
end;

procedure TMMTimer.SetEnabled;
begin
  if Not Assigned(Self) then Exit;
  if Value <> Enabled then begin
    prEnabled := Value;
    UpdateTimer;
  end;
end;

function  TMMTimer.GetEnabled: Boolean;
begin
  if Assigned(Self) then
    Result:= prEnabled
  else
    Result:= FALSE;
end;

procedure TMMTimer.SetInterval;
begin
  if Not Assigned(Self) then Exit;
  if Value <> Interval then begin
    prDelay := Value;
    UpdateTimer;
  end;
end;

procedure TMMTimer.SetResolution;
begin
  if Not Assigned(Self) then Exit;
  if Value <> Resolution then begin
    prResolution := Value;
    UpdateTimer;
  end;
end;

procedure TMMTimer.SetOnTimer;
begin
  if Not Assigned(Self) then Exit;
  prOnTimer := Value;
  UpdateTimer;
end;

procedure TMMTimer.TypeSet(Value: TMMTimerType);
begin
  if Not Assigned(Self) then Exit;
  prTimerType:=Value;
end;

procedure TMMTimer.FlagSet(f:TMMTFlag);
begin
  if Not Assigned(Self) then Exit;
  Include(prFlags,f);
end;

procedure TMMTimer.FlagClear(f:TMMTFlag);
begin
  if Not Assigned(Self) then Exit;
  Exclude(prFlags,f);
end;

procedure TMMTimer.Timer;
  var DoOnTimer:TNotifyEvent;
begin
  if Not Assigned(Self) then Exit;
  if fTerminated in prFlags then Exit;
  if not (fFPUReset in Flags) then begin
    asm
      FNINIT
      FWAIT
      FLDCW   Default8087CW
    end;
    Include(prFlags,fFPUReset);
  end;
  try
    DoOnTimer:=OnTimer;
    if not (fTerminated in prFlags) and Assigned(DoOnTimer) then begin
      try
        DoOnTimer(Self);
      except
        if not (fDoNotStopOnException in Flags) then
          Enabled:=FALSE;
      end;
    end;
    if not (fTerminated in prFlags) and (TimerType=ttPeriodicEx) then begin
      UpdateTimer;
    end;
  except end;
end;

function  TMMTimer.EventGet:uint;
begin
  if Not Assigned(Self) then  begin
    Result:=cTimerType2Timer[ttOnce];
  end else begin
    Result:=cTimerType2Timer[TimerType];
  end;
end;

function  TMMTimer.ParameterGet(p:TMMTimerPar):uint;
  var TC:tTIMECAPS; mmres:MMRESULT;
begin
  mmres:=timeGetDevCaps(@TC, sizeof(TC));
  case p of
    mmpParsAvailable: Result:=mmres;
    mmpMinREsolution: Result:=TC.wPeriodMin;
    mmpMaxResolution: Result:=TC.wPeriodMax;
    else Result:=0;
  end;
end;

END.