transeff.pas

Do your applications look a little boring? Would you like to get spectacular yet easy to use visual

unit TransEff;

interface

{$INCLUDE teDefs.inc}

uses 
  {$IFDEF WIN32}
  Windows, Messages,
  {$ENDIF WIN32}
  SysUtils, Classes, Consts,
  {$ifdef CLX}
  QT, QForms, QGraphics, QControls;
  {$else}
  Graphics, Controls,Forms, teChrono;
  {$endif CLX}

{$ifndef TE_NOHLP}
const
  CM_TENAMECHANGED = CM_BASE + 533;
{$endif TE_NOHLP}

type
  TTEPassSettingType  = (teOnePass, teTwoPasses, tePaletteDependent);
  TTEEffectDirection  = (tedNone, tedRight, tedLeft, tedDown, tedUp,
    tedDownRight, tedDownLeft, tedUpRight, tedUpLeft, tedIn, tedOut);
  TTEEffectDirections = set of TTEEffectDirection;

  ETransitionEffectError = class(Exception);

  TTransitionEffect  = class;
  TTEAbortQueryEvent = procedure(Sender: TObject; Transition: TTransitionEffect;
    var Abort: Boolean) of object;

  {$ifdef D3C3}
  TCustomFormClass = class of TCustomForm;
  {$endif D3C3}

  TTEPass2OptionsType = class(TPersistent)
  private
    FDistributedTime,
    FReversed,
    FUseSolidColor: Boolean;
    FSolidColor: TColor;
  public
    constructor Create; virtual;

    procedure Assign(Source: TPersistent); override;
  published
    property DistributedTime: Boolean read FDistributedTime write FDistributedTime default False;
    property Reversed: Boolean read FReversed write FReversed default False;
    property UseSolidColor: Boolean read FUseSolidColor write FUseSolidColor default True;
    property SolidColor: TColor read FSolidColor write FSolidColor default clNone;
  end;

  TTETransitionData = class;
{$ifndef TE_NOHLP}
  TTERenderWindow    = class;
  TFCDirtyRects     = class;
{$endif TE_NOHLP}
  TTransitionList   = class;

  TTransitionEffect = class(TComponent)
  private
    FDirection: TTEEffectDirection;
    FAborted,
    FExecuting,
    FFrozen,
    FPrepared,
    FReversed,
    FClientCoordinates: Boolean;
    FTransitionList: TTransitionList;
    OldImage,
    BackGroundImage,
    NewImage: TBitmap;
    SaveCtrl: TControl;
    SaveR,
    ScreenR: TRect;
    AbortChrono: TTEChrono;
    FAbortOnClick,
    FAbortOnEscape,
    FEnabled,
    FFlickerFreeWhenDisabled: Boolean;
    FMinAbortInterval: Longint;       //V34
    FMilliseconds: Longint;
    FPass2Options: TTEPass2OptionsType;
    FPassSetting: TTEPassSettingType;
    SaveStyle: Longint;

    FOnAbortQuery: TTEAbortQueryEvent;
    FOnAfterTransition,
    FOnBeforeTransition,
    FOnStartTransition,
    FOnEndTransition: TNotifyEvent;

    procedure SetDirection(Value: TTEEffectDirection);
    function  GetIndex: Integer;
    procedure SetIndex(Value: Integer);
    procedure SetEnabled(const Value: Boolean);
    procedure SetTransitionList(const Value: TTransitionList);
    function  GetVersion: String;
    procedure SetVersion(const Value: String);
  protected
    AllowScreenUpdate,
    UseClientCoordinates,
    SecondPass,
    HasRgn: Boolean;
    OffScreenBmp: TBitmap;
    UnUpdateRect,
    UpdateRect,
    UpdateRectBak,
    UnUpdateRectBak: TRect;
    DirtyRects: TFCDirtyRects;
    {$ifdef LogTiming}
    RefreshTimer: TTEChrono;
    {$endif LogTiming}

    procedure SetName(const Value: TComponentName); override;
    function  DirectionToUse: TTEEffectDirection;
    function  ReversedDirection: TTEEffectDirection; virtual;
    function  Disabled: Boolean;
    procedure DoExecute(Data: TTETransitionData); virtual; abstract;
    function  GetBitmapsWidth(const DefaultWidth: Integer): Integer; virtual;
    function  GetPixelFormat: TPixelFormat; virtual;
    function  NeedDstImage: Boolean; virtual;
    function  NeedSrcImage: Boolean; virtual;
    procedure ReadState(Reader: TReader); override;
    function  RenderWhenClipped: Boolean; virtual;
    function  ReversedToUse: Boolean;
    procedure UpdateScreen(FullUpdate: Boolean);
    function  UseOffScreenBmp: Boolean; virtual;
    function  UseSrcAsOffScreenBmp: Boolean; virtual;
    procedure CheckAbort(CheckTimer: Boolean); //V34
  public
    AllowedDirections: TTEEffectDirections;
    RenderWindow: TTERenderWindow;
    ForceRendering,
    ForceClippedMode,
    NeverRendering: Boolean;
    {$ifndef TE_NOHLP}
    ClipRgn: HRGN;
    {$endif TE_NOHLP}

    constructor Create(AOwner: TComponent{$ifdef DP} = nil{$endif}); override;
    destructor  Destroy; override;

    class function Description: String; virtual;

    {$ifndef TE_NOHLP}
    procedure Abort;
    {$endif TE_NOHLP}
    procedure Assign(Source: TPersistent); override;
    function  HasParent: Boolean; override;
    function  GetParentComponent: TComponent; override;
    class function GetEditor: String; virtual;
    procedure SetParentComponent(AParent: TComponent); override;
    function  AllowTransition: Boolean;
    function  Clipped: Boolean;
    procedure Defrost;
    procedure Execute;
    function  Freeze(Ctrl: TControl; R: TRect): Boolean;
    function  Passes: Integer;
    function  Prepare(Ctrl: TControl; R: TRect): Boolean;
    procedure Prepare2ndPass;
    function  TwoPassesCapable: Boolean; virtual;
    procedure UnPrepare;

    property Aborted: Boolean read FAborted;
    property ClientCoordinates: Boolean read FClientCoordinates write FClientCoordinates default True;
    property Direction: TTEEffectDirection read FDirection write SetDirection;
    property Executing: Boolean read FExecuting;
    property Frozen: Boolean read FFrozen;
    {$ifndef TE_NOHLP}
    property Index: Integer read GetIndex write SetIndex stored False;
    {$endif TE_NOHLP}
    property Milliseconds: Longint read FMilliseconds write FMilliseconds default 0;
    property MinAbortInterval: Longint read FMinAbortInterval write FMinAbortInterval default 300; //V33
    property Prepared: Boolean read FPrepared;
    property Reversed: Boolean read FReversed write FReversed default False;
    {$ifndef TE_NOHLP}
    property TransitionList: TTransitionList read FTransitionlist write SetTransitionList;
    {$endif TE_NOHLP}
  published
    property AbortOnClick: Boolean read FAbortOnClick write FAbortOnClick default False;
    property AbortOnEscape: Boolean read FAbortOnEscape write FAbortOnEscape default False;
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property FlickerFreeWhenDisabled: Boolean read FFlickerFreeWhenDisabled write FFlickerFreeWhenDisabled default False;
    property Pass2Options: TTEPass2OptionsType read FPass2Options write FPass2Options;
    property PassSetting: TTEPassSettingType read FPassSetting write FPassSetting default teOnePass;
    property Version: String read GetVersion write SetVersion stored False;

    property OnAbortQuery: TTEAbortQueryEvent read FOnAbortQuery write FOnAbortQuery;
    property OnAfterTransition: TNotifyEvent read FOnAfterTransition write FOnAfterTransition;
    property OnBeforeTransition: TNotifyEvent read FOnBeforeTransition write FOnBeforeTransition;
    property OnEndTransition  : TNotifyEvent read FOnEndTransition   write FOnEndTransition;
    property OnStartTransition: TNotifyEvent read FOnStartTransition write FOnStartTransition;
  end;

  {$ifndef TE_NOHLP}
  TTERenderWindow = class(TCustomControl)
  public
    Palette: HPALETTE;

    constructor Create(AOwner: TComponent); override;

    property Canvas;
  protected
    {$ifndef CLX}
    procedure CreateParams(var Params: TCreateParams); override;
    {$endif CLX}
  private
    {$ifndef CLX}
    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
    {$endif CLX}
  end;
  {$endif TE_NOHLP}

  TTransitionEffectClass = class of TTransitionEffect;
  PTransitionEffect = ^TTransitionEffect;

  {$ifndef TE_NOHLP}
  TCMTENameChanged = packed record
    Msg: Cardinal;
    Transition: TTransitionEffect;
    Unused,
    Result: Longint;
  end;
  {$endif TE_NOHLP}

  TTransitionList = class(TComponent)
  private
    FTransitions: TList;

    function  GetTransition(Index: Integer): TTransitionEffect;
    procedure SetTransition(Index: Integer; const Value: TTransitionEffect);
    function  GetVersion: String;
    procedure SetVersion(const Value: String);
  protected
    function  GetTransitionCount: Integer;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    {$ifndef TE_NOHLP}
    Editor: TForm;
    {$endif TE_NOHLP}

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

    procedure AddTransition(Transition: TTransitionEffect);
    procedure RemoveTransition(Transition: TTransitionEffect);

    property TransitionCount: Integer read GetTransitionCount;
    property Transitions[Index: Integer]: TTransitionEffect read GetTransition write SetTransition; default;
  published
    property Version: String read GetVersion write SetVersion stored False;
  end;

  TTETransitionData = class(TObject)
  private
    FBitmap: TBitmap;
    FSrcBmp,
    FDstBmp: TBitmap;
    FScreenCanvas: TCanvas;
    FWidth,
    FHeight: Integer;
    FPixelFormat: TPixelFormat;
    FIsRGB: Boolean;
    FRealTime: Boolean;
    function GetCanvas: TCanvas;
  public
    constructor Create(WidthValue: Integer; HeightValue: Integer;
      SrcBmpValue: TBitmap; DstBmpValue: TBitmap; BitmapValue: TBitmap;
      ScreenCanvasValue: TCanvas; PixelFormatValue: TPixelFormat;
      RealTime: Boolean); virtual;
    property Bitmap: TBitmap read FBitmap write FBitmap;
    property Canvas: TCanvas read GetCanvas;
    property DstBmp: TBitmap read FDstBmp;
    property Height: Integer read FHeight;
    property IsRGB: Boolean read FIsRGB;
    property PixelFormat: TPixelFormat read FPixelFormat;
    property RealTime: Boolean read FRealTime;
    property ScreenCanvas: TCanvas read FScreenCanvas;
    property SrcBmp: TBitmap read FSrcBmp;
    property Width : Integer read FWidth;
  end;

  {$ifndef TE_NOHLP}
  TFCDirtyRects = class(TObject)
  private
    FRects: TList;

    function  GetRect(Index: Integer): TRect;
    procedure SetRect(Index: Integer; const Value: TRect);
  protected
    function  GetRectCount: Integer;
  public
    CheckBounds,
    AutoClear{,
    CheckOverlapping}: Boolean;
    Bounds: TRect;

    constructor Create;
    destructor  Destroy; override;

    procedure AddRect(R: TRect);
    procedure RemoveRect(Index: Integer);
    procedure Clear;

    property Count: Integer read GetRectCount;
    property Rects[Index: Integer]: TRect read GetRect write SetRect; default;
  end;
  {$endif TE_NOHLP}

  TFlickerFreeTransition = class(TTransitionEffect)
  public
    class function Description: String; override;
  protected
    procedure DoExecute(Data: TTETransitionData); override;
    function  NeedSrcImage: Boolean; override;
    {$ifndef CLX}
    function  GetPixelFormat: TPixelFormat; override;
    {$endif CLX}
  end;

  function  TEGetDirectionDesc(Direction: TTEEffectDirection): String;
  procedure TERegisterTransition(TransitionEffectClass: TTransitionEffectClass);

var
  TERegisteredTransitions: TList;
  FlickerFreeTransition: TFlickerFreeTransition;
  TEGlobalDisabled: Boolean;
  {$ifndef TE_NOHLP}
  OldTransition,
  NewTransition: TTransitionEffect;
  TETransitionPrepared: Boolean;
  {$endif TE_NOHLP}
implementation

uses ComCtrls, teRender;

type
  TTEWinControl          = class(TWinControl);
  TTECustomForm          = class(TCustomForm);
  TTEScrollingWinControl = class(TScrollingWinControl);

{ Common procedures and functions }

function TEGetDirectionDesc(Direction: TTEEffectDirection): String;
begin
  case Direction of
    tedNone     : Result := '';
    tedRight    : Result := 'Right';
    tedLeft     : Result := 'Left';
    tedDown     : Result := 'Down';
    tedUp       : Result := 'Up';
    tedDownRight: Result := 'Down and right';
    tedDownLeft : Result := 'Down and left';
    tedUpRight  : Result := 'Up and right';
    tedUpLeft   : Result := 'Up and left';
    tedIn       : Result := 'In';
    tedOut      : Result := 'Out';
    else          Result := '';
  end;
end;

procedure TERegisterTransition(TransitionEffectClass: TTransitionEffectClass);
begin
  if TERegisteredTransitions = nil then
    TERegisteredTransitions := TList.Create;

  if TERegisteredTransitions.IndexOf(TransitionEffectClass) = -1 then
    TERegisteredTransitions.Add(TransitionEffectClass);

  {$ifdef D6UP}
  StartClassGroup(TControl);
  ActivateClassGroup(TControl);
  GroupDescendentsWith(TransitionEffectClass, Controls.TControl);
  {$endif D6UP}

  Classes.RegisterClass(TransitionEffectClass);
end;

procedure SetChildOrderAfter(Child: TWinControl; Control: TControl);
var
  i: Integer;
begin
  for i:=0 to Child.Parent.ControlCount do
  begin
    if Child.Parent.Controls[i] = Control then
    begin
      TTEWinControl(Child.Parent).SetChildOrder(Child, i+1);
      break;
    end;
  end;
end;

{ TTEPass2OptionsType }

constructor TTEPass2OptionsType.Create;
begin
  FDistributedTime := False;
  FReversed        := False;
  FUseSolidColor   := True;
  FSolidColor      := clNone;
end;

procedure TTEPass2OptionsType.Assign(Source: TPersistent);
var
  aux: TTEPass2OptionsType;
begin
  if Source is TTEPass2OptionsType
  then
  begin
    aux := (Source as TTEPass2OptionsType);

    FDistributedTime := aux.DistributedTime;
    FReversed        := aux.Reversed;
    FUseSolidColor   := aux.UseSolidColor;
    FSolidColor      := aux.SolidColor;
  end
  else
  inherited Assign(Source);
end;

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

  Caption   := 'teRenderWindow';
  Visible   := False;
  Palette   := 0;
  Color     := clPurple;
end;

{$ifndef CLX}
procedure TTERenderWindow.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);

  with Params do
  begin
    if (Parent = nil) and (ParentWindow = 0) then
    begin