fibsafetimer.pas

FIBPlus version 6-96. This is somewhat usefull interbase database components. TFIBDatabase, TFIBTab

{***************************************************************}
{ FIBPlus - component library for direct access to Firebird and }
{ InterBase databases                                           }
{                                                               }
{    FIBPlus is based in part on the product                    }
{    Free IB Components, written by Gregory H. Deatz for        }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.            }
{    mailto:[e-mail]                                    }
{                                                               }
{    Copyright (c) 1998-2009 Devrace Ltd.                       }
{    Written by Serge Buzadzhy ([e-mail])               }
{                                                               }
{ ------------------------------------------------------------- }
{    FIBPlus home page: http://www.fibplus.com/                 }
{    FIBPlus support  : http://www.devrace.com/support/         }
{ ------------------------------------------------------------- }
{                                                               }
{  Please see the file License.txt for full license information }
{***************************************************************}

unit FIBSafeTimer;

interface

uses
  Windows, SysUtils, Classes;

type
{$I FIBPlus.inc}
  { TFIBCustomTimer }

  TFIBCustomTimer = class(TComponent)
  private
    FActive: Boolean;
    FHandle: Integer;
    FInterval: Integer;
    FOnTimer: TNotifyEvent;
    procedure SetActive(const Value: Boolean);
    procedure SetInterval(const Value: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
{    procedure Start;
    procedure Stop;}
    property  Enabled: Boolean read FActive write SetActive;
    property  Interval: Integer read FInterval write SetInterval;
    property  OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
  end;

implementation

var
  TimerList: TThreadList;

type
  TSyncThread=class(TThread)
  protected
    FTimer:TFIBCustomTimer;
    procedure Execute; override;
    procedure DoOnTimer;
  end;
  
procedure TimerProc(HWND, uMsg, idEvent, dwTime : Integer); stdcall;
var
  I: Integer;
  Timer: TFIBCustomTimer;
  List:TList;
  st:TSyncThread;
begin
  I := 0;
  List:=TimerList.LockList;
  try
    while I < List.Count do
    begin
      Timer := List.Items[I];
      if (Timer <> nil) and (idEvent = Timer.FHandle) and
         (Assigned(Timer.FOnTimer))
      then
      begin
        if GetCurrentThreadID = MainThreadID then
          Timer.FOnTimer(Timer)
        else
        begin
          st:=TSyncThread.Create(True);
          try
           st.FTimer:=Timer;
           st.Synchronize(st.DoOnTimer);
          finally
           st.Free
          end;
        end ;
        Exit; {恹镱腠