mmhtimer.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [phone]               =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/index.html               =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 07.10.98 - 21:01:39 $                                        =}
{========================================================================}
unit MMHTimer;

{$I COMPILER.INC}

{$C FIXED PRELOAD PERMANENT}

{.$DEFINE _MMDEBUG}

interface

uses
{$IFDEF WIN32}
  Windows,
{$ELSE}
  WinTypes,
  WinProcs,
{$ENDIF}
  SysUtils,
  Messages,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  MMSystem,
  MMUtils,
  MMString,
  MMObj;

type
  EMMHiTimerError = class(Exception);

  {$IFDEF WIN32}
  TMMHiTimer      = class;

  {-- TMMTimerThread ---------------------------------------------------}
  TMMTimerThread  = class(TMMThreadEx)
  private
     HiTimer    : TMMHiTimer;
     Terminating: Boolean;
     procedure Execute; override;
  end;
  {$ENDIF}

  {-- TMMHiTimer -------------------------------------------------------}
  TMMHiTimer = class(TMMNonVisualComponent)
  private
  {$IFDEF WIN32}
    FPriority         : TThreadPriority;
    FTimerThread      : TMMTimerThread;
    FTimerEvent       : THandle;
    FGeneralEvent     : THandle;
    FSynchronize      : Boolean;
    FThreadCreated    : Boolean;
    FWaitForTerminate : Boolean;
    FMainThreadWaiting: Boolean;
  {$ENDIF}
    FEnabled          : Boolean;
    FInterval         : integer;
    FMessageCount     : integer;
    FHandle           : THandle;
    FTimerID          : integer;
    FCallbackMode     : TMMCBMode;

    FOnTimer          : TNotifyEvent;

    procedure SetCallBackMode(aValue: TMMCBMode);
    procedure SetEnabled(aValue: Boolean);
    procedure SetInterval(aValue: integer);
    procedure SetOnTimer(aValue: TNotifyEvent);
    function  GetTimerCaps: TTimeCaps;
    procedure UpdateTimer;
    procedure WndProc(var Msg: TMessage);
    {$IFDEF WIN32}
    procedure SetPriority(aValue: TThreadPriority);
    {$ENDIF}
    procedure DoTimer;

  protected
    procedure Timer; dynamic;

  public
    constructor Create(AOwner:TComponent); override;
    destructor  Destroy; override;
    {$IFDEF WIN32}
    procedure SynchronizeVCL(VCLProc: TThreadMethod);
    {$ENDIF}

    procedure ChangeDesigning(aValue: Boolean); override;

  published
    property CallBackMode: TMMCBMode read FCallBackMode write SetCallBackMode default cmWindow;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property Interval: integer read FInterval write SetInterval default 1000;
    property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
    {$IFDEF WIN32}
    property Priority: TThreadPriority read FPriority write SetPriority default tpNormal;
    property Synchronize: Boolean read FSynchronize write FSynchronize default True;
    property WaitForTerminate: Boolean read FWaitForTerminate write FWaitForTerminate default False;
    {$ENDIF}
  end;

implementation

Uses
    Consts
    {$IFDEF _MMDEBUG}
    ,MMDebug
    {$ENDIF};

{$IFDEF _MMDEBUG}
{-------------------------------------------------------------------------}
procedure Debug(Level: integer; s: String);
begin
   if (s <> ' ') then s := 'HiTimer: '+s;
   DB_WriteStrLn(Level,s);
end;
{$ENDIF}

{-- TimeCallBack -------------------------------------------------------}
procedure TimeCallBack(uTimerID, uMessage: UINT; dwUser, dw1, dw2: Longint);
export;{$IFDEF WIN32}stdcall;{$ENDIF}
begin
   if (dwUser <> 0) then
   with TMMHiTimer(dwUser) do
   {$IFDEF WIN32}
   try
   {$ELSE}
   begin
   {$ENDIF}
      case FCallBackMode of
         cmWindow  : if (FMessageCount < 10) then
                     begin
                        inc(FMessageCount);
                        PostMessage(FHandle,MM_TIMER,uTimerID,0);
                     end;
         cmCallBack: DoTimer;
         {$IFDEF WIN32}
         cmThread  : SetEvent(FTimerEvent);
         {$ENDIF}
      end;

   {$IFDEF WIN32}
   except
      Application.HandleException(nil);
   {$ENDIF}
   end;
end;

{$IFDEF WIN32}
{== TMMTimerThread =====================================================}
procedure TMMTimerThread.Execute;
var
   h: THandle;
begin
   if (HiTimer <> nil) then
   try
      Priority := HiTimer.FPriority;

      { Ready to go, set the general event }
      SetEvent(HiTimer.FGeneralEvent);

      {$IFDEF _MMDEBUG}
      Debug(0,'Timer ThreadProc started...');
      {$ENDIF}

      while not Terminated and not Terminating and (HiTimer <> nil) do
      begin
         WaitForSingleObject(HiTimer.FTimerEvent,INFINITE);
         if not Terminated and not Terminating and (HiTimer <> nil) then
            HiTimer.DoTimer;
      end;

      if (HiTimer <> nil) then
      begin
         h := HiTimer.FGeneralEvent;
         HiTimer.FTimerThread := nil;
         HiTimer := nil;
         SetEvent(h);
      end;

   except
      Application.HandleException(Self);
   end;

   {$IFDEF _MMDEBUG}
   Debug(0,'Timer ThreadProc terminated...');
   {$ENDIF}
end;
{$ENDIF}

{== TMMHiTimer =========================================================}
procedure TMMHiTimer.WndProc(var Msg: TMessage);
begin
   with Msg do
   if (Msg = MM_TIMER) and (wParam = FTimerID) then
   try
      try
         Timer;
      finally
         dec(FMessageCount);
      end;
   except
      Application.HandleException(Self);
   end
   else Result := DefWindowProc(FHandle, Msg, wParam, lParam);
end;

{-- TMMHiTimer -----------------------------------------------------------}
constructor TMMHiTimer.Create(aOwner: TComponent);
begin
   inherited Create(aOwner);

   FEnabled := True;
   FInterval := 1000;
   FTimerID  := 0;
   FHandle := 0;
   FMessageCount := 0;
   FCallBackMode := cmWindow;
{$IFDEF WIN32}
   FPriority := tpNormal;
   FSynchronize := True;
   FThreadCreated := False;
   FWaitForTerminate := False;
   FMainThreadWaiting := False;
{$ENDIF}
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;

{-- TMMHiTimer -----------------------------------------------------------}
destructor TMMHiTimer.Destroy;
begin
   FOnTimer := nil;
   FEnabled := False;
   UpdateTimer;

   inherited destroy;
end;

{-- TMMHiTimer -----------------------------------------------------------}
procedure TMMHiTimer.ChangeDesigning(aValue: Boolean);
begin
   inherited;

   UpdateTimer;
end;

{-- TMMHiTimer -----------------------------------------------------------}
Procedure TMMHiTimer.SetCallBackMode(aValue: TMMCBMode);
begin
   if (aValue <> FCallBackMode) then
   begin
      if (aValue = cmCallBack) then
      begin
         {$IFDEF WIN32}
         if not _WIN95_ then
         {$ENDIF}
         begin
            Application.MessageBox('"CallBacks" are called at interrupt time !'#10#13+
                                   'This is currently only supported under Windows 95',
                                   'TMMHiTimer', MB_OK);
            exit;
         end;
      end;
      FCallBackMode := aValue;
      UpdateTimer;
   end;
end;

{-- TMMHiTimer -----------------------------------------------------------}
procedure TMMHiTimer.SetEnabled(aValue: Boolean);
begin
   if (aValue <> FEnabled) then
   begin
     FEnabled := aValue;
     UpdateTimer;
   end;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK2}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;

{-- TMMHiTimer -----------------------------------------------------------}
procedure TMMHiTimer.SetInterval(aValue: integer);
begin
   if (aValue <> FInterval) then
   begin
      FInterval := aValue;
      UpdateTimer;
   end;
end;

{-- TMMHiTimer -----------------------------------------------------------}
procedure TMMHiTimer.SetOnTimer(aValue: TNotifyEvent);
begin
   FOnTimer := aValue;
   UpdateTimer;
end;

{-- TMMHiTimer -----------------------------------------------------------}
function TMMHiTimer.GetTimerCaps: TTimeCaps;
var
   Temp:TTimeCaps;

begin
   TimeGetDevCaps(@Temp, sizeof(Temp));
   Result := Temp;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK2}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;

{-- TMMHiTimer -----------------------------------------------------------}
procedure TMMHiTimer.UpdateTimer;
var
{$IFNDEF WIN32}
   TimeCB: TTimeCallBack;
{$ENDIF}
   Msg: TMsg;
begin
   if (csDesigning in ComponentState) then exit;

   {$IFDEF WIN32}
   if FThreadCreated then
   begin
      {$IFDEF _MMDEBUG}
      Debug(0,'Shot down Thread...');
      {$ENDIF}

      FTimerThread.Terminating := True;

      { in case it is suspended remove all before terminate }
      while FTimerThread.Suspended do FTimerThread.Resume;

      FTimerThread.Terminate;

      { force the thread to wake }
      SetEvent(FTimerEvent);

      { ...and wait for it to die }
      if FWaitForTerminate and not FMainThreadWaiting then
         WaitForSingleObject(FGeneralEvent, 5000);

      if (FTimerThread <> nil) then
          FTimerThread.HiTimer := nil;

      { free the events }
      CloseHandle(FGeneralEvent);
      CloseHandle(FTimerEvent);

      FThreadCreated := False;

      {$IFDEF _MMDEBUG}
      Debug(0,'Thread now stopped...');
      {$ENDIF}
   end;
   {$ENDIF}

   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK3}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}

   if (FTimerID <> 0) then
   begin
      TimeKillEvent(FTimerID);
      FTimerID := 0;
      if (FHandle <> 0) then
      begin
         { remove pending messages }
         while PeekMessage(Msg, FHandle, MM_TIMER, MM_TIMER, PM_REMOVE) do;
         DeallocateHWnd(FHandle);
         FHandle := 0;
         FMessageCount := 0;
      end;
      TimeEndPeriod(GetTimerCaps.wPeriodMin);
   end;

   if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
   begin
      case FCallBackMode of
         cmWindow: FHandle := AllocateHWnd(WndProc);
         {$IFDEF WIN32}
         cmThread:
         begin
            {$IFDEF _MMDEBUG}
            Debug(0,'Try to start Thread...');
            {$ENDIF}

            FGeneralEvent := CreateEvent(nil, False, False, nil);
            FTimerEvent := CreateEvent(nil,False,False,nil);

            FTimerThread := TMMTimerThread.Create(True);
            if (FTimerThread = nil) then
               raise EMMHiTimerError.Create('HiTimer:'#10#13+LoadResStr(IDS_THREADERROR));

            FTimerThread.HiTimer := Self;
            FTimerThread.FreeOnTerminate := True;
            FTimerThread.Terminating := False;
            FThreadCreated := True;
            FTimerThread.Resume;

            { Wait for it to start... }
            if WaitForSingleObject(FGeneralEvent, 5000) <> WAIT_OBJECT_0 then

               raise EMMHiTimerError.Create('HiTimer:'#10#13+LoadResStr(IDS_THREADERROR));

            {$IFDEF _MMDEBUG}
            Debug(0,'Thread started...');
            {$ENDIF}
         end
         {$ENDIF}
      end;

      {$IFDEF WIN32}
      TimeBeginPeriod(GetTimerCaps.wPeriodMin);
      FTimerID := TimeSetEvent(FInterval, 0, @TimeCallBack, Longint(Self), TIME_PERIODIC);
      {$ELSE}
      TimeCB := TimeCallBack;
      TimeBeginPeriod(GetTimerCaps.wPeriodMin);
      FTimerID := TimeSetEvent(FInterval, 0, TimeCB, Longint(Self), TIME_PERIODIC);
      {$ENDIF}
      if (FTimerID = 0) then
         raise EOutOfResources.Create({$IFDEF DELPHI3}SNoTimers{$ELSE}LoadStr(SNoTimers){$ENDIF});
   end;
end;

{$IFDEF WIN32}
{-- TMMHiTimer -----------------------------------------------------------}
procedure TMMHiTimer.SetPriority(aValue: TThreadPriority);
begin
   if aValue <> FPriority then
   begin
      FPriority := aValue;
      if FThreadCreated then
      begin
         FTimerThread.Priority := FPriority;
      end;
   end;
end;

{-- TMMHiTimer -----------------------------------------------------------}
procedure TMMHiTimer.SynchronizeVCL(VCLProc: TThreadMethod);
begin
   if (FCallBackMode = cmThread) and FThreadCreated then
   begin
      FMainThreadWaiting := True;
      FTimerThread.Synchronize(VCLProc);
      FMainThreadWaiting := False;
   end;
end;
{$ENDIF}

{-- TMMHiTimer -----------------------------------------------------------}
procedure TMMHiTimer.DoTimer;
begin
   {$IFDEF WIN32}
   if (FCallBackMode = cmThread) and FSynchronize then
      SynchronizeVCL(Timer)
   else
   {$ENDIF}
      Timer;
end;

{-- TMMHiTimer -----------------------------------------------------------}
procedure TMMHiTimer.Timer;
begin
   if Assigned(FOnTimer) and FEnabled then FOnTimer(Self);
end;

end.