Componentes.Terceros.DevExpressVCL/official/x.35/ExpressBars 6/Sources/dxFading.pas

{*******************************************************************}
{                                                                   }
{       Developer Express Visual Component Library                  }
{       ExpressBars components                                      }
{                                                                   }
{       Copyright (c) 1998-2008 Developer Express Inc.              }
{       ALL RIGHTS RESERVED                                         }
{                                                                   }
{   The entire contents of this file is protected by U.S. and       }
{   International Copyright Laws. Unauthorized reproduction,        }
{   reverse-engineering, and distribution of all or any portion of  }
{   the code contained in this file is strictly prohibited and may  }
{   result in severe civil and criminal penalties and will be       }
{   prosecuted to the maximum extent possible under the law.        }
{                                                                   }
{   RESTRICTIONS                                                    }
{                                                                   }
{   THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES           }
{   (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE    }
{   SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS   }
{   LICENSED TO DISTRIBUTE THE EXPRESSBARS AND ALL ACCOMPANYING VCL }
{   CONTROLS AS PART OF AN EXECUTABLE PROGRAM ONLY.                 }
{                                                                   }
{   THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED      }
{   FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE        }
{   COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE       }
{   AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT  }
{   AND PERMISSION FROM DEVELOPER EXPRESS INC.                      }
{                                                                   }
{   CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON       }
{   ADDITIONAL RESTRICTIONS.                                        }
{                                                                   }
{*******************************************************************}

unit dxFading;

{$I cxVer.inc}

interface

uses
{$IFDEF DELPHI6}
  Types,
{$ENDIF}
  Windows, Classes, SysUtils, Graphics, cxGraphics, ExtCtrls;

const
  dxDefaultStageCount: Integer     = 12;
  dxDefaultStageInterval: Integer  = 20;

type
  TdxFadingList = class;

  IdxFadingObject = interface
  ['{73AB2A92-CDD9-4F13-965A-DC799DE837F9}']
    function CanFade: Boolean;
    procedure DrawBitmap(ABitmap: TBitmap);
    procedure GetFadingParams(out AFadeOutImage, AFadeInImage: TBitmap;
      var AFadeInStageCount, AFadeInStageInterval,
          AFadeOutStageCount, AFadeOutStageInterval: Integer);
  end;

  { TdxFadingElement }

  TdxFadingState = (fsFadeIn, fsFadeOut);

  TdxFadingElement = class
  private
    FTimer: TTimer;
    FFadeOutImage: TBitmap;
    FFadeInImage: TBitmap;
    FFadingObject: IdxFadingObject;
    FElement: TObject;
    FOwner: TdxFadingList;
    FStage: Integer;
    FFadeInStageCount: Integer;
    FFadeInStageInterval: Integer;
    FFadeOutStageCount: Integer;
    FFadeOutStageInterval: Integer;
    FState: TdxFadingState;
    procedure CreateTimer;
    procedure GetFadingParams;
    procedure SetState(const Value: TdxFadingState);
    procedure ValidateStageParams;
  protected
    procedure DrawBlended(Alpha: Byte);
    function GetInvertedStage: Integer;
    function GetStageAlpha: Byte;
    procedure OnTimer(Sender: TObject);

    property FadeInStageCount: Integer read FFadeInStageCount;
    property FadeInStageInterval: Integer read FFadeInStageInterval;
    property FadeOutStageCount: Integer read FFadeOutStageCount;
    property FadeOutStageInterval: Integer read FFadeOutStageInterval;
    property Owner: TdxFadingList read FOwner;
    property Stage: Integer read FStage;
  public
    constructor Create(AOwner: TdxFadingList; AElement: TObject;
      AState: TdxFadingState);
    destructor Destroy; override;
    procedure Finalize;

    property Element: TObject read FElement;
    property State: TdxFadingState read FState write SetState;
  end;

  { TdxFadingList }

  TdxFadingList = class(TList)
  private
    FClearing: Boolean;
    function GetItems(Index: Integer): TdxFadingElement;
  protected
    property Clearing: Boolean read FClearing;
  public
    procedure Clear; override;
    property Items[Index: Integer]: TdxFadingElement read GetItems; default;
  end;

  { TdxFader }

  TdxFader = class
  private
    FList: TdxFadingList;
    FQueueDepth: Integer;
    procedure SetQueueDepth(Value: Integer);
    procedure ValidateQueue;
  protected
    procedure DoFade(AObject: TObject; AState: TdxFadingState);
    function Find(AObject: TObject): TdxFadingElement;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    function Contains(AObject: TObject): Boolean;
    procedure FadeIn(AObject: TObject);
    procedure FadeOut(AObject: TObject);
    procedure Remove(AObject: TObject; ADestroying: Boolean = True);
    property QueueDepth: Integer read FQueueDepth write SetQueueDepth;
  end;

implementation

uses
  Math, Forms;

const
  dxMaxStageCount = 32;
  dxMaxStageInterval = 300;
  dxMaxFadingQueueDepth = 8;

{ TdxFadingElement }

constructor TdxFadingElement.Create(AOwner: TdxFadingList;
  AElement: TObject; AState: TdxFadingState);
begin
  inherited Create;
  FOwner := AOwner;
  FElement := AElement;
  FState := AState;
  Supports(AElement, IdxFadingObject, FFadingObject);
  GetFadingParams;
  CreateTimer;
end;

destructor TdxFadingElement.Destroy;
begin
  FreeAndNil(FTimer);
  if not Owner.Clearing then
    Owner.Remove(Self);
  FFadingObject := nil;
  FFadeOutImage.Free;
  FFadeInImage.Free;
  inherited Destroy;
end;

procedure TdxFadingElement.Finalize;
var
  ABitmap: TBitmap;
begin
  if State = fsFadeIn then
    ABitmap := FFadeInImage
  else
    ABitmap := FFadeOutImage;
  FFadingObject.DrawBitmap(ABitmap);
  Free;
end;

procedure TdxFadingElement.DrawBlended(Alpha: Byte);
var
  B: TBitmap;
begin
  B := TBitmap.Create;
  try
  {$IFDEF DELPHI10}
    B.SetSize(FFadeOutImage.Width, FFadeOutImage.Height);
  {$ELSE}
    B.Width := FFadeOutImage.Width;
    B.Height := FFadeOutImage.Height;
  {$ENDIF}
    cxAlphaBlend(B, FFadeOutImage, FFadeInImage, Alpha);
    FFadingObject.DrawBitmap(B);
  finally
    B.Free;
  end;
end;

function TdxFadingElement.GetInvertedStage: Integer;
var
  A: Integer;
begin
  A := GetStageAlpha;
  if State = fsFadeIn then
    Result := Min(FadeOutStageCount, A div (256 div (FadeOutStageCount + 1)))
  else
    Result := Min(FadeInStageCount, A div (256 div (FadeInStageCount + 1)));
end;

function TdxFadingElement.GetStageAlpha: Byte;
begin
  if State = fsFadeIn then
  begin
    if Stage >= FFadeInStageCount then
      Result := 255
    else
      Result := Min(255, Stage * (256 div FadeInStageCount));
  end
  else
  begin
    if Stage >= FadeOutStageCount then
      Result := 0
    else
      Result := Max(0, 255 - Stage * (256 div FadeOutStageCount));
  end;
end;

procedure TdxFadingElement.OnTimer(Sender: TObject);
begin
  if ((State = fsFadeIn) and (Stage >= FadeInStageCount)) or
     ((State = fsFadeOut) and (Stage >= FadeOutStageCount)) then
    Finalize
  else
  begin
    Inc(FStage);
    DrawBlended(GetStageAlpha);
  end;
end;

procedure TdxFadingElement.CreateTimer;
begin
  FTimer := TTimer.Create(nil);
  FTimer.Interval := FFadeInStageInterval;
  FTimer.OnTimer := OnTimer;
end;

procedure TdxFadingElement.GetFadingParams;
begin
  FFadeInStageCount := dxDefaultStageCount;
  FFadeInStageInterval := dxDefaultStageInterval;
  FFadeOutStageCount := dxDefaultStageCount;
  FFadeOutStageInterval := dxDefaultStageInterval;
  FFadingObject.GetFadingParams(FFadeOutImage, FFadeInImage,
    FFadeInStageCount, FFadeInStageInterval, FFadeOutStageCount,
    FFadeOutStageInterval);
  ValidateStageParams;
end;

procedure TdxFadingElement.ValidateStageParams;
begin
  if FFadeInStageCount < 0 then
    FFadeInStageCount := dxDefaultStageCount
  else if FFadeInStageCount > dxMaxStageCount then
    FFadeInStageCount := dxMaxStageCount;
  if FFadeInStageInterval < 10 then
    FFadeInStageInterval := dxDefaultStageInterval
  else if FFadeInStageInterval > dxMaxStageInterval then
    FFadeInStageInterval := dxMaxStageInterval;
  if FFadeOutStageCount < 0 then
    FFadeOutStageCount := dxDefaultStageCount
  else if FFadeOutStageCount > dxMaxStageCount then
    FFadeOutStageCount := dxMaxStageCount;
  if FFadeOutStageInterval < 10 then
    FFadeOutStageInterval := dxDefaultStageInterval
  else if FFadeOutStageInterval > dxMaxStageInterval then
    FFadeOutStageInterval := dxMaxStageInterval;
end;

procedure TdxFadingElement.SetState(const Value: TdxFadingState);
begin
  if FState <> Value then
  begin
    FStage := GetInvertedStage;
    FState := Value;
    FTimer.Enabled := False;
    if State = fsFadeIn then
      FTimer.Interval := FadeInStageInterval
    else
      FTimer.Interval := FadeOutStageInterval;
    FTimer.Enabled := True;
  end;
end;

{ TdxFadingList }

procedure TdxFadingList.Clear;
var
  I: Integer;
begin
  FClearing := True;
  try
    for I := 0 to Count - 1 do
      Items[I].Free;
  finally
    FClearing := False;
  end;
  inherited Clear;
end;

function TdxFadingList.GetItems(Index: Integer): TdxFadingElement;
begin
  Result := TdxFadingElement(List^[Index]);
end;

{ TdxFader }

constructor TdxFader.Create;
begin
  inherited Create;
  FList := TdxFadingList.Create;
  FQueueDepth := 6;
end;

destructor TdxFader.Destroy;
begin
  Clear;
  FList.Free;
  inherited Destroy;
end;

procedure TdxFader.Clear;
begin
  while FList.Count > 0 do
    FList[0].Finalize;
end;

function TdxFader.Contains(AObject: TObject): Boolean;
begin
  Result := Find(AObject) <> nil;
end;

procedure TdxFader.FadeIn(AObject: TObject);
begin
  DoFade(AObject, fsFadeIn);
end;

procedure TdxFader.FadeOut(AObject: TObject);
begin
  DoFade(AObject, fsFadeOut);
end;

procedure TdxFader.DoFade(AObject: TObject; AState: TdxFadingState);
var
  AElement: TdxFadingElement;
  AIntf: IdxFadingObject;
begin
  if not Supports(AObject, IdxFadingObject, AIntf) or not AIntf.CanFade then Exit;
  AElement := Find(AObject);
  if AElement = nil then
  begin
    FList.Add(TdxFadingElement.Create(FList, AObject, AState));
    ValidateQueue;
  end
  else
    AElement.State := AState;
end;

function TdxFader.Find(AObject: TObject): TdxFadingElement;
var
  I: Integer;
begin
  Result := nil;
  for I := 0 to FList.Count - 1 do
    if FList[I].Element = AObject then
    begin
      Result := FList[I];
      Break;
    end;
end;

procedure TdxFader.Remove(AObject: TObject; ADestroying: Boolean = True);
var
  AElement: TdxFadingElement;
begin
  AElement := Find(AObject);
  if AElement <> nil then
  begin
    if ADestroying then
      AElement.Free
    else
      AElement.Finalize;
  end;
end;

procedure TdxFader.SetQueueDepth(Value: Integer);
begin
  if Value < 0 then Value := 0;
  if Value > dxMaxFadingQueueDepth then
    Value := dxMaxFadingQueueDepth;
  if FQueueDepth <> Value then
  begin
    FQueueDepth := Value;
    ValidateQueue;
  end;
end;

procedure TdxFader.ValidateQueue;
begin
  while FList.Count > FQueueDepth do
    FList[0].Finalize;
end;

end.