//*****************************************************************************/
//             Name : MMTimer                                                  /
//      Description : Replacement for Standard Delphi Timer Based on Windows   /
//                    API Multimedia Timer with CallBacks.                     /
//          Version : 2.0                                                      /
//           Status : Freeware.                                                /
//*****************************************************************************/
//          Authors : Andrew Hill & Guy Tessier                                /
//           E-Mail : a.hill@cairnweb.com                                      /
//*****************************************************************************/
//       Properties : Enabled    : Boolean                                     /
//                    Interval   : LongWord                                    /
//                    Resolution : LongWord                                    /
//           Events : OnTimer    : TNotifyEvent                                /
//*****************************************************************************/
//         Comments : This unit is freeware, use it as you will. We ask only   /
//                    that if you use it you give us credit and send us an     /
//                    email and if you modify the code you send us a copy.     /
//                    This is in no-way a real time clock, but it looks a lot  /
//                    funkier than the bog standard Delphi timer.              /
//*****************************************************************************/
//       Disclaimer : This code is distributed without copyright and neither   /
//                    Andrew Hill or Guy Tessier accept any responsibility     /
//                    for any consequences of its use.                         /
//*****************************************************************************/

unit L_MMTimer;

interface

uses
  Classes,SysUtils,Windows;

type
  EMMTimer=      class(Exception);
  TMMTimer=      class(TComponent)
  private
    fTimerID:    DWord;
    fInterval:   DWord;
    fResolution: DWord;
    fEnabled:    Boolean;
    fOnTimer:    TNotifyEvent;
    procedure    Start;
    procedure    Stop;
    procedure    SetEnabled(Enabled: Boolean);
    procedure    SetInterval(Interval: DWord);
    procedure    SetResolution(Resolution: DWord);
  protected
    procedure    Loaded;override;
  public
    constructor  Create(AOwner:TComponent);override;
    destructor   Destroy;override;
  published
    property     Enabled: Boolean read fEnabled write SetEnabled default False;
    property     Interval: DWord read fInterval write SetInterval default 100;
    property     Resolution: DWord read fResolution write SetResolution default 10;
    property     OnTimer: TNotifyEvent read fOnTimer write fOnTimer default nil;
  end;

procedure Register;

implementation

const TIME_PERIODIC=1;

type TCallBack=procedure(aTimerID,aMessage,aTimerUser,DW1,DW2: DWord);stdcall;

function timeSetEvent(Del,Res: DWord; Func: TCallBack; User,Flags: DWord): DWord;stdcall;
external 'winmm.dll' name 'timeSetEvent';

function timeKillEvent(ID: DWord): DWord;stdcall;
external 'winmm.dll' name 'timeKillEvent';

procedure CallBack(uTimerID,uMessage: DWord; dwUser,dw1,dw2: DWord);stdcall;
begin
  if Assigned(TMMTimer(dwUser))then
    if Assigned(TMMTimer(dwUser).fOnTimer) then
      TMMTimer(dwUser).fOnTimer(TMMTimer(dwUser));
  if not Assigned(TMMTimer(dwUser))then
    if uTimerID<>0 then TimeKillEvent(uTimerID);
end;

procedure TMMTimer.Start;
begin
  if csDesigning in ComponentState then Exit;
  Stop;
  fTimerID:=TimeSetEvent(fInterval,fResolution,CallBack,DWord(Self),TIME_PERIODIC);
  if fTimerID=0 then RaiseLastOSError; // EMMTimer.Create('Unable to start multimedia timer.');
end;

procedure TMMTimer.Stop;
begin
  if fTimerID<>0 then TimeKillEvent(fTimerID);
  fTimerID:=0;
end;

procedure TMMTimer.SetEnabled(Enabled: Boolean);
begin
  fEnabled:=Enabled;
  if fEnabled then Start else Stop;
end;

procedure TMMTimer.SetInterval(Interval: DWord);
begin
  fInterval:=Interval;
  if fEnabled then Start;
end;

procedure TMMTimer.SetResolution(Resolution: DWord);
begin
  fResolution:=Resolution;
  if fEnabled then Start;
end;

procedure TMMTimer.Loaded;
begin
  inherited Loaded;
end;

constructor TMMTimer.Create(AOwner:TComponent);
begin
  inherited Create(AOwner);
  fOnTimer:=nil;
  fTimerID:=0;
  Enabled:=False;
  Interval:=100;
  Resolution:=10;
end;

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

procedure Register;
begin
  RegisterComponents('System',[TMMTimer]);
end;

end.
