abflasht.pas

著名的虚拟仪表控件,包含全部源码, 可以在,delphi2007 下安装运行

unit AbFlashT;

{******************************************************************************}
{ Abakus VCL                                                                   }
{                         Component TAbFlashTimer                              }
{                                                                              }
{******************************************************************************}
{        e-Mail: [e-mail] , Web: http://www.abaecker.com            }
{------------------------------------------------------------------------------}
{          (c) Copyright 1998..2001 A.Baecker, All rights Reserved             }
{******************************************************************************}

{$I abks.inc}

interface

uses
  Windows,
  Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  extctrls, 
  {****** Abakus VCL - Units ******}
  _AbInfo, _AbFlash;

type
  TAbFlashProc = Procedure(WPar, LPar : Longint);

  PFlashRecord = ^TFlash;
  TFlash = record
    Control       : TControl;             // to add a control to the flashlist
    FlashProc     : TAbFlashProc;         // to add a procedure to the FlashList
    IntervalTime  : {$IFDEF V4UP} Int64 {$ELSE} LongInt {$ENDIF};                // interval time in ms
    NextPulseTime : {$IFDEF V4UP} Int64 {$ELSE} LongInt {$ENDIF};                // Next puls in Tickcount
    FlashBit      : Boolean ;             //
  end;

  TFlashFreq = (ff8Hz, ff4Hz, ff2Hz, ff1Hz, ff05Hz);

  TAbFlashTimer = class(TAbFlash)
  private
    FAbInfo: TAbInfo;
    { Private-Deklarationen }
  protected
    { Protected-Deklarationen }
    procedure flash(sender: TObject);
  public
    { Public-Deklarationen }
    constructor create(aowner: tcomponent); override;
    destructor destroy; override;
  published
    { Published-Deklarationen }
    property AbInfo: TAbInfo read FAbInfo write FAbInfo stored false;
  end;

const
  WM_FLASH          = WM_USER + 100;

  Freq8Hz           = 2;                {bit no. in Var "tim"}
  Freq4Hz           = 3;                {bit no. in Var "tim"}
  Freq2Hz           = 4;                {bit no. in Var "tim"}
  Freq1Hz           = 5;                {bit no. in Var "tim"}
  Freq05Hz          = 6;                {bit no. in Var "tim"}

  SyncOneSec        = 32;               {synchronized one second pulses}

var
  dynFlashList      : TList;
  AFlashRecord      : PFlashRecord;
  AbFlashTimer      : TAbFlashTimer;

  NextSecPuls       : TDateTime;

// methods to add/delete a procedure-call
procedure AddProc(Proc: TAbFlashProc; Interval: {$IFDEF V4UP} Int64 {$ELSE} LongInt {$ENDIF});
procedure DelProc(Proc: TAbFlashProc);
procedure DelProcNo(no: Smallint);

// methods to add/delete a control
procedure AddControl(Control: TControl; Interval: {$IFDEF V4UP} Int64 {$ELSE} LongInt {$ENDIF});
procedure DelControl(Control: TControl);
procedure DelControlNo(no: Smallint);

procedure ClearFlashList;

implementation

uses _GClass;

var
  running           : Smallint = 0;
  tim               : Cardinal = 0;
  OneSec            : TDateTime  ;

procedure CreateTimer;
begin
  if AbFlashTimer <> nil then exit;
  AbFlashTimer := TAbFlashTimer.create(nil);
end;

procedure DestroyTimer;
begin
  if AbFlashTimer <> nil then begin
     AbFlashTimer.Free;
     AbFlashTimer := NIL;
  end;
end;

destructor TAbFlashTimer.destroy;
begin
  dec(running);
  inherited destroy;
end;

constructor TAbFlashTimer.create(aowner: tcomponent);
begin
  try
    inc(running);
    inherited create(aowner);
    if (running = 1) then begin
      OnTimer := flash;

      {xxxxxxxxxxx Abakus-Info's xxxxxxxxxxxxx}
      AbInfo := LoadAbakusInfo;
      {xxxxxxxxxxx Abakus-Info's xxxxxxxxxxxxx}

    end else begin
      Application.MessageBox(
        'Only one TAbFlashTimer per Application!'
        + chr(13) + 'Remove it...',
        'Error Message', MB_OK);
    end;
  finally
  end;
end;


procedure TAbFlashTimer.flash(sender: TObject);
var
  n                 : Smallint;
  NewSec            : Boolean;
  BitNow            : Boolean;
  isProc, isControl : Boolean;
  TimeNow           : TDateTime;
  tickcount         : Cardinal;
  AbsDiffTime       : LongInt;
  DiffTime          : LongInt;
  dt                : LongInt;

begin
  if tim < High(Cardinal) then
    Inc(tim)
  else
    tim := 0;

  tickcount := GetTickCount;
  TimeNow := now;

  if TimeNow >= NextSecPuls then
  begin                                 {synchronized 1sec pulses}
    NextSecPuls := now + OneSec;
    NewSec := true;
    if tn then begin
      MessageDlg( 'Abakus VCL Error 78 ! ', mtError	,[mbOk], 0);
    end;
  end
  else
    NewSec := false;

  for n := 0 to dynFlashList.Count - 1 do
  begin
    try
      begin
        if (csDestroying in Application.ComponentState) then exit;
        if n >= dynFlashList.Count then exit;
        AFlashRecord := dynFlashList.Items[n];
        isControl := (AFlashRecord.Control <> nil);
        isProc := Assigned(AFlashRecord.FlashProc);

        if isControl or isProc then
        begin
          case AFlashRecord.IntervalTime of {synchronized pulses for blinking}
            Freq8Hz..Freq05Hz:
              begin
                BitNow := (tim and (1 SHL AFlashRecord.IntervalTime) <> 0);
                // detect changes
                if AFlashRecord.FlashBit  <> BitNow  then begin
                  AFlashRecord.FlashBit := BitNow;
                  if isControl then
                      AFlashRecord.Control.perform(WM_FLASH, tim, Ord(BitNow))
                  else
                    if isProc then AFlashRecord.FlashProc(tim, Ord(BitNow));
                end;
              end;
            SyncOneSec:
              begin                     {synchronized 1sec pulses}
                if NewSec then
                begin
                  if isControl then
                      AFlashRecord.Control.perform(WM_FLASH, tim, 0)
                  else
                    if isProc then AFlashRecord.FlashProc(tim, 0);
                end;
              end;
          else                          {free interval}
            begin
              dt := tickcount - AFlashRecord.NextPulseTime;
              AbsDiffTime := ABS(dt);

              if (AFlashRecord.NextPulseTime <= tickcount) or (AbsDiffTime >=
                MaxInt) then
              begin
                if AbsDiffTime < MaxInt then
                  DiffTime := tickcount - AFlashRecord.NextPulseTime
                else
                  DiffTime := 0;

                if AbsDiffTime > 1000 then AbsDiffTime := 0;

                if DiffTime >= 0 then begin
                  AFlashRecord.NextPulseTime := tickcount +
                    AFlashRecord.IntervalTime - AbsDiffTime;
                end else begin
                  AFlashRecord.NextPulseTime := tickcount +
                    AFlashRecord.IntervalTime + AbsDiffTime;
                end;
                if isControl then
                  AFlashRecord.Control.perform(WM_FLASH, tim, AbsDiffTime)
                else
                  if isProc then AFlashRecord.FlashProc(tim, AbsDiffTime);
              end;
            end;
          end;                          {case IntervalTime of}
        end
        else
        begin                           // AFlashRecord.Control = nil
          if isControl then
            DelControlNo(n)
          else
            if isProc then
              DelProcNo(n)
        end; // if AFlashRecord.Control <> nil then begin
    end except
      on EIntOverflow do ;              {on overflow or RangeError do nothing}
      on ERangeError do ;
    else                                
      //
    end;
  end;
end;


procedure AddProc(Proc: TAbFlashProc; Interval: {$IFDEF V4UP} Int64 {$ELSE} LongInt {$ENDIF});
var
  n                 : Smallint;
  neu               : Boolean;
begin
  neu := true;
  if dynFlashList = nil then exit;
  if Assigned(Proc) then
  begin
    // check if Proc is allredy in dynFlashList, if yes then change time
    for n := 0 to dynFlashList.Count - 1 do
    begin
      AFlashRecord := dynFlashList.Items[n];
      if (@AFlashRecord.FlashProc = @Proc) then
      begin
        AFlashRecord.IntervalTime := Interval;
        AFlashRecord.NextPulseTime := getTickCount + Interval;
        neu := false;
      end;
    end;
    // create a new item in dynFlashList
    if neu then
    begin
      New(AFlashRecord);
      AFlashRecord.Control := nil;
      AFlashRecord.FlashProc := Proc;
      AFlashRecord.IntervalTime := Interval;
      AFlashRecord.NextPulseTime := getTickCount + Interval;
      dynFlashList.Add(AFlashRecord);
    end;
    // to reduce the number of memory allocations in TList
    if (dynFlashList.Capacity - dynFlashList.Count < 2) then
    begin
      dynFlashList.Capacity := dynFlashList.Count + 10;
    end;
    // start timer if needed
    if dynFlashList.Count > 0 then begin
      CreateTimer;
    end;
  end;

end;

procedure AddControl(Control: TControl; Interval: {$IFDEF V4UP} Int64 {$ELSE} LongInt {$ENDIF});
var
  n                 : Smallint;
  neu               : Boolean;
begin
  neu := true;
  if Assigned(Control) then
  begin
    // check if control is allredy in dynFlashList, if yes then change time
    for n := 0 to dynFlashList.Count - 1 do
    begin
      AFlashRecord := dynFlashList.Items[n];
      if AFlashRecord.Control = Control then
      begin
        AFlashRecord.IntervalTime := Interval;
        AFlashRecord.NextPulseTime := getTickCount + Interval;
        neu := false;
      end;
    end;
    // create a new item in dynFlashList
    if neu then
    begin
      New(AFlashRecord);
      AFlashRecord.Control := Control;
      AFlashRecord.IntervalTime := Interval;
      AFlashRecord.NextPulseTime := getTickCount + Interval;
      dynFlashList.Add(AFlashRecord);
    end;
    // to reduce the number of memory allocations in TList
    if (dynFlashList.Capacity - dynFlashList.Count < 2) then
    begin
      dynFlashList.Capacity := dynFlashList.Count + 10;
    end;
    // start timer if needed
    if dynFlashList.Count > 0 then begin
      CreateTimer;
    end;

  end;
end;


procedure DelControlNo(no: Smallint);
begin
  if no < dynFlashList.Count then
  begin
    AFlashRecord := dynFlashList.Items[no];
    Dispose(AFlashRecord);
    dynFlashList.delete(no);
    dynFlashList.Pack;
    AFlashRecord := nil;
  end;
end;

procedure DelProcNo(no: Smallint);
begin
  DelControlNo(no);
end;

procedure DelProc(Proc: TAbFlashProc);
var
  n                 : Smallint;
begin
  for n := dynFlashList.Count - 1 downto 0 do
  begin
    AFlashRecord := dynFlashList.Items[n];
    if (@AFlashRecord.FlashProc = @Proc) then
    begin
      DelControlNo(n);
      Break;
    end;
  end;
  // Stop timer if needed
  if (csDestroying in Application.ComponentState) and
     (dynFlashList.Count = 0) then begin
    DestroyTimer;
  end;

end;

procedure DelControl(Control: TControl);
var
  n                 : Smallint;
begin
  for n := 0 to dynFlashList.Count - 1 do
  begin
    AFlashRecord := dynFlashList.Items[n];
    if AFlashRecord.Control = Control then
    begin
      DelControlNo(n);
      Break;
    end;
  end;
  // Stop timer if needed
  if (csDestroying in Application.ComponentState) and
     (dynFlashList.Count = 0) then begin
    DestroyTimer;
  end;
end;

procedure ClearFlashList;
var
  n                 : Integer;
begin
  for n := 0 to dynFlashList.Count - 1 do
  begin
    AFlashRecord := dynFlashList.Items[n];
    Dispose(AFlashRecord);
  end;
end;



initialization
  OneSec := EncodeTime(0,0,1,0);
  NextSecPuls := now + OneSec;
  dynFlashList := TList.Create;

finalization
  DestroyTimer;
  ClearFlashList;
  dynFlashList.Free;
end.