mmltimer.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: [phone]                   =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.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: 20.01.1998 - 18:00:00 $                                      =}
{========================================================================}
unit MMLTimer;

{$C FIXED PRELOAD PERMANENT}
{$I COMPILER.INC}

interface

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

type
    {-- TMMLongTimer ------------------------------------------------------}
    TMMLongTimer = class(TMMNonVisualComponent)
    private
      FEnabled : Boolean;
      FInterval: Longint;
      FCounter : Longint;
      FOnTimer : TNotifyEvent;

      procedure SetEnabled(aValue: Boolean);
      procedure SetInterval(aValue: Longint);
      procedure SetOnTimer(aValue: TNotifyEvent);

    protected
      procedure Timer; dynamic;

    public
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;

    published
      property Enabled: Boolean read FEnabled write SetEnabled default True;
      property Interval: Longint read FInterval write SetInterval default 1;
      property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
    end;

implementation

uses Consts,MMSystem;

type
   PTimerRec = ^TTimerRec;
   TTimerRec = record
     TimerID    : Longint;
     TimerCount : Longint;
     CBHandle   : THandle;
     ControlList: TList;
   end;

const
   lpTimerRec : PTimerRec = nil;

{-- TimeCallBack -------------------------------------------------------}
procedure TimeCallBack(uTimerID, uMessage: UINT; dwUser, dw1, dw2: Longint);
export;{$IFDEF WIN32}stdcall;{$ENDIF}
var
   i: integer;
begin
   if (dwUser <> 0) then
   with PTimerRec(dwUser)^ do
   begin
      if (ControlList.Count > 0) then
      for i := 0 to ControlList.Count-1 do
      with TMMLongTimer(ControlList.Items[i]) do
      begin
         if (FInterval <> 0) and FEnabled and assigned(FOnTimer) then
         begin
           inc(FCounter);
           if (FCounter = FInterval) then
           begin
              FCounter := 0;
              PostMessage(CBHandle,MM_TIMER,TimerID,Longint(ControlList.Items[i]));
           end;
        end;
      end;
   end;
end;

{------------------------------------------------------------------------}
function TimerWndProc(Window: HWND; Message, wParam: UINT; lParam: Longint): Longint;
export;{$IFDEF WIN32}stdcall;{$ENDIF}
begin
   if (lpTimerRec <> nil) and (lpTimerRec^.ControlList <> nil) then
   with lpTimerRec^ do
   begin
      if (Message = MM_TIMER) and (wParam = TimerID) and (ControlList.Count > 0) then
      with ControlList do
      begin
         if (IndexOf(Pointer(lParam)) <> -1) then
         try
            TMMLongTimer(lParam).Timer;
         except
            Application.HandleException(nil);
         end;
      end
      else Result := DefWindowProc(Window, Message, wParam, lParam);
   end;
end;

const
  TMMTimerWindowClass: TWndClass = (
    style: 0;
    lpfnWndProc: @TimerWndProc;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: nil;
    lpszClassName: 'TMMLongTimerWindow');

{------------------------------------------------------------------------}
function AllocateTimerWindow: HWND;
var
   TempClass: TWndClass;
   ClassRegistered: Boolean;
begin
   TMMTimerWindowClass.hInstance := HInstance;
   ClassRegistered := GetClassInfo(HInstance,
                      TMMTimerWindowClass.lpszClassName, TempClass);
    if not ClassRegistered or (TempClass.lpfnWndProc <> @TimerWndProc) then
    begin
       {$IFDEF WIN32}
       if ClassRegistered then
          Windows.UnregisterClass(TMMTimerWindowClass.lpszClassName, HInstance);
       Windows.RegisterClass(TMMTimerWindowClass);
       {$ELSE}
       if ClassRegistered then
          WinProcs.UnregisterClass(TMMTimerWindowClass.lpszClassName, HInstance);
       WinProcs.RegisterClass(TMMTimerWindowClass);
       {$ENDIF}
    end;
    Result := CreateWindow(TMMTimerWindowClass.lpszClassName, '', 0,
                           0, 0, 0, 0, 0, 0, HInstance, nil);
end;

{------------------------------------------------------------------------}
procedure UpdateTimer(Enabled: Boolean);
{$IFNDEF WIN32}
var
   TimeCB: TTimeCallBack;
{$ENDIF}

begin
   if (lpTimerRec <> nil) then
   with lpTimerRec^ do
   begin
      if (TimerID <> 0) then
      begin
         TimeKillEvent(TimerID);
         TimerID := 0;
      end;

      if Enabled then
      begin
         {$IFDEF WIN32}
         TimerID := TimeSetEvent(1000, 1000, @TimeCallBack, Longint(lpTimerRec), TIME_PERIODIC);
         if (TimerID = 0) then
            raise EOutOfResources.Create({$IFDEF DELPHI3}SNoTimers{$ELSE}LoadStr(SNoTimers){$ENDIF});
         {$ELSE}
         TimeCB := TimeCallBack;
         TimerID := TimeSetEvent(1000, 1000, TimeCB, Longint(lpTimerRec), TIME_PERIODIC);
         if (TimerID = 0) then
            raise EOutOfResources.Create(LoadStr(SNoTimers));
         {$ENDIF}
      end;
   end;
end;

{------------------------------------------------------------------------}
procedure AddTimer(Timer: TMMLongTimer);
begin
   if (lpTimerRec = nil) then
   begin
      lpTimerRec := GlobalAllocPtr(GPTR,sizeOf(TTimerRec));
      lpTimerRec^.TimerCount := 0;
      lpTimerRec^.ControlList := TList.Create;
      lpTimerRec^.CBHandle := AllocateTimerWindow;
      UpdateTimer(True);
   end;
   if (lpTimerRec^.ControlList.IndexOf(Timer) = -1) then
   begin
      lpTimerRec^.ControlList.Add(Timer);
      inc(lpTimerRec^.TimerCount);
   end;
end;

{------------------------------------------------------------------------}
procedure RemoveTimer(Timer: TMMLongTimer);
begin
   if (lpTimerRec <> nil) then
   begin
      lpTimerRec^.ControlList.Remove(Timer);
      lpTimerRec^.ControlList.Pack;
      dec(lpTimerRec^.TimerCount);
      if (lpTimerRec^.TimerCount = 0) then
      begin
         UpdateTimer(False);
         lpTimerRec^.ControlList.Free;
         lpTimerRec^.ControlList := nil;
         DestroyWindow(lpTimerRec^.CBHandle);
         GlobalFreePtr(lpTimerRec);
         lpTimerRec := nil;
      end;
   end;
end;

{-- TMMLongTimer ---------------------------------------------------------}
constructor TMMLongTimer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FEnabled := True;
  FInterval := 1;
  FCounter := 0;

  ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
  if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;

{-- TMMLongTimer ---------------------------------------------------------}
destructor TMMLongTimer.Destroy;
begin
   Enabled := False;

   inherited Destroy;
end;

{-- TMMLongTimer ---------------------------------------------------------}
procedure TMMLongTimer.SetEnabled(aValue: Boolean);
begin
  if (aValue <> FEnabled) then
  begin
    FEnabled := aValue;
    FCounter := 0;
    if FEnabled then
       AddTimer(Self)
    else
       RemoveTimer(Self);
  end;
  {$IFDEF WIN32}
  {$IFDEF TRIAL}
  {$DEFINE _HACK1}
  {$I MMHACK.INC}
  {$ENDIF}
  {$ENDIF}
end;

{-- TMMLongTimer ---------------------------------------------------------}
procedure TMMLongTimer.SetInterval(aValue: Longint);
begin
  if (aValue <> FInterval) then
  begin
    FInterval := aValue;
    FCounter := 0;
  end;
  {$IFDEF WIN32}
  {$IFDEF TRIAL}
  {$DEFINE _HACK2}
  {$I MMHACK.INC}
  {$ENDIF}
  {$ENDIF}
end;

{-- TMMLongTimer ---------------------------------------------------------}
procedure TMMLongTimer.SetOnTimer(aValue: TNotifyEvent);
begin
  FOnTimer := aValue;
  FCounter := 0;
end;

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

end.