tevclscr.pas

delphi2007界面效果控件源码

unit teVclScr;

interface

uses Windows, Messages, SysUtils, Classes, Controls, Forms, Graphics, TransEff;

{$INCLUDE teDefs.inc}

type
  TTERenderWindow = class(TCustomControl)
  private
    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    Palette: HPalette;
    BkPicture: TBitmap;

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

    property Canvas;
  end;

  TTEVCLScreenTrDevice = class(TTETransitionDevice)
  private
    FRenderWindow: TTERenderWindow;
    FPrepared: Boolean;
    FFrozen: Boolean;
    FClientCoordinates: Boolean;
  protected
    SaveCtrl: TControl;
    SaveR,
    ScreenR: TRect;
    SaveStyle: Longint;
    OpeningForm,
    ClosingForm,
    UseClientCoordinates: Boolean;
    {$ifndef TE_NOHLP}
    ClipRgn: HRGN;
    LayerAlpha: Byte;
    LayerKey: COLORREF;
    LayerFlags: DWord;
    {$endif TE_NOHLP}
    procedure CustomExecute; override;
    function  GetDelegateTransition(Original: TTransitionEffect;
      const ReturnCopy: Boolean): TTransitionEffect; override;
    function GetRenderWndHandle: HWnd; override;
    class function TransitionIsDisabled(Transition: TTransitionEffect;
      NoFlickerFreeWhenDisabled: Boolean): Boolean; override;
  public
    constructor Create; override;
    destructor  Destroy; override;
    function AvoidScrolling: Boolean; override;

    function  Clipped: Boolean; override;
    procedure Defrost;
    procedure Execute(WaitForCompletion: Boolean = True); override;
    function  Freeze(Ctrl: TControl; R: TRect): Boolean;
    procedure GetOffScreenBmp(var OldPalette: hPalette); override;
    function  HasPalette: Boolean; override;
    function  PixelFormat: TPixelFormat; override;
    function  Prepare(Ctrl: TControl; R: TRect): Boolean;
    procedure Prepare2ndPass;
    function  TwoPassesCapable: Boolean; override;
    procedure UnPrepare;

    property ClientCoordinates: Boolean read FClientCoordinates write FClientCoordinates;
    property Frozen: Boolean read FFrozen;
    property Prepared: Boolean read FPrepared;
    property RenderWindow: TTERenderWindow read FRenderWindow;
  end;

var
  {$ifndef TE_NOHLP}
  TEVclScrPrepared: Boolean; // Avoids nested transitions
  {$endif TE_NOHLP}

implementation

uses teRender, ComCtrls, teChrono, teTimed;

const
  WS_EX_LAYERED = $00080000;

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

  TLayeredBlendTransition = class(TTimedTransitionEffect)
  public
    Opening: Boolean;
    MaxAlpha: Byte;
    Key: COLORREF;
    Flags: DWord;
  protected
    function  GetInfo(Device: TTETransitionDevice): TTETransitionInfo; override;
    procedure Initialize(Data: TTETransitionData; var TotalFrames: Longint); override;
    procedure ExecuteFrame(Data: TTETransitionData; CurrentFrame, Step,
      LastExecutedFrame: Longint); override;
    procedure Finalize(Data: TTETransitionData); override;
  end;

constructor TTEVCLScreenTrDevice.Create;
begin
  inherited;

  ClipRgn            := 0;
  FClientCoordinates := True;
  FFrozen            := False;
  FPrepared          := False;
  OpeningForm        := False;
  ClosingForm        := False;
  FRenderWindow      := nil;
end;

destructor TTEVCLScreenTrDevice.Destroy;
begin
  UnPrepare;

  inherited;
end;

function TTEVCLScreenTrDevice.Clipped: Boolean;
var
  RenderHandle: HWnd;
begin
  if SaveCtrl <> nil
  then
  begin
    if RenderWindow <> nil
    then RenderHandle := RenderWindow.Handle
    else RenderHandle := 0;
    Result := IsWindowClipped(TWinControl(SaveCtrl).Handle, RenderHandle, ScreenR);
  end
  else Result := False;
end;

procedure TTEVCLScreenTrDevice.Defrost;
var
  ParentWindow: TWinControl;
begin
  if RenderWindow <> nil then
  begin
    if ClipRgn <> 0 then
    begin
      DeleteObject(ClipRgn);
      ClipRgn := 0;
    end;

    ParentWindow := RenderWindow.Parent;
    // This avoids flickering under some circumstances
    if ParentWindow <> nil then
      ParentWindow.DisableAlign;

    if SaveStyle <> 0 then
    begin
      SetWindowLong(ParentWindow.Handle, GWL_STYLE, SaveStyle);
      SaveStyle := 0;
    end;

    RenderWindow.Free;
    if ParentWindow <> nil then
    begin
      ParentWindow.ControlState := ParentWindow.ControlState - [csAlignmentNeeded];
      ParentWindow.EnableAlign;
    end;
    FRenderWindow := nil;
  end;
  SaveCtrl := nil;

  if Data <> nil then
    Finalize;

  FFrozen  := False;
end;

procedure TTEVCLScreenTrDevice.Execute(WaitForCompletion: Boolean = True);
begin
  if(ClipRgn <> 0) and Assigned(RenderWindow)
  then // this has to be done before UseOffScreenBmp is called
  begin
    SetWindowRgn(RenderWindow.Handle, ClipRgn, False);
    ClipRgn := 0;
  end;

  inherited;
end;

function TTEVCLScreenTrDevice.Freeze(Ctrl: TControl; R: TRect): Boolean;
var
  Bounds: TRect;
  ParentCtrl: TWinControl;
  Order,
  Ok: Boolean;
  VHandle: HWnd;
  Cursor: TCursor;
  Flags: DWord;

  procedure SetCtrlToParent;
  begin
    if Ctrl.Parent = nil then
      Exit;

    if not UseClientCoordinates
    then
    begin
      with ControlClientOffset(Ctrl) do
        OffsetRect(R, Ctrl.Left + X, Ctrl.Top + Y);
    end
    else OffsetRect(R, Ctrl.Left, Ctrl.Top);
    Ctrl := Ctrl.Parent;
    UseClientCoordinates := True;
  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;

begin
  if TransitionToUse = nil then
    raise ETransitionEffectError.Create(rsTEDevTrIsNil);

  Result := False;

  if Frozen then
  begin
    if(Ctrl = SaveCtrl)
    then
    begin
      Result := True;
      Exit;
    end
    else Defrost;
  end;

  if not AllowTransition then
    exit;

  if TEVclScrPrepared then
    exit;

  Cursor := Ctrl.Cursor;

  UseClientCoordinates := ClientCoordinates;
  if not(Ctrl is TWinControl) then
    SetCtrlToParent;

  Ok := True;
  repeat
    if not Ok then
      SetCtrlToParent;

    if Ctrl.Parent is TPageControl then
      SetCtrlToParent;

    if(Ctrl is TForm) and (TForm(Ctrl).FormStyle = fsMDIChild)
    then VHandle := Application.MainForm.Handle
    else VHandle := TWinControl(Ctrl).Handle;

    Ok := IsWindowVisible(VHandle);
  until Ok or (Ctrl.Parent = nil);

  if not Ok then
    Exit;

  if not UseClientCoordinates then
  begin
    with ControlClientOffset(Ctrl) do
    begin
      if(X <= R.Left) and
        (Y <= R.Top ) and
        ((R.Right  - X) <= ControlClientWidth (Ctrl)) and
        ((R.Bottom - Y) <= ControlClientHeight(Ctrl)) then
      begin
        UseClientCoordinates := True;
        OffsetRect(R, -X, -Y);
      end;
    end;
  end;

  if(not UseClientCoordinates)            and
    (Ctrl is TForm)                       and
    (TForm(Ctrl).FormStyle <> fsMDIChild) and
    (Ctrl.Parent = nil)
  then ScreenR := R
  else
  begin
    ScreenR.TopLeft     := ControlClientToScreen(Ctrl, R.TopLeft);
    ScreenR.BottomRight := ControlClientToScreen(Ctrl, R.BottomRight);

    if not UseClientCoordinates then
      with ControlClientOffset(Ctrl) do
        OffsetRect(ScreenR, -X, -Y);
  end;

  if not OpeningForm then
    Ctrl.Update;
//  Application.ProcessMessages; // This messes up events

  Order := False;
  if UseClientCoordinates and (not ClosingForm)
  then ParentCtrl := TWinControl(Ctrl)
  else
  begin
    if Ctrl.Parent <> nil
    then
    begin
      ParentCtrl := Ctrl.Parent;
      Order      := True
    end
    else ParentCtrl := nil;
  end;

  if ParentCtrl = nil
  then Bounds := ScreenR
  else
  begin
    Bounds.TopLeft     := ControlScreenToClient(ParentCtrl, ScreenR.TopLeft);
    Bounds.BottomRight := ControlScreenToClient(ParentCtrl, ScreenR.BottomRight);
  end;

  SaveCtrl := Ctrl;
  SaveR.TopLeft     := ControlScreenToClient(SaveCtrl, ScreenR.TopLeft);
  SaveR.BottomRight := ControlScreenToClient(SaveCtrl, ScreenR.BottomRight);
  if not UseClientCoordinates then
  begin
    with ControlClientOffset(SaveCtrl) do
      OffsetRect(SaveR, X, Y);
  end;

  try
    if Data = nil then
      Initialize;
    if not(TransitionToUse is TLayeredBlendTransition) then
    begin
      FRenderWindow := TTERenderWindow.Create(Ctrl);
      RenderWindow.Cursor := Cursor;
    end;

    if ParentCtrl <> nil
    then
    begin
      RenderWindow.Parent := ParentCtrl;
      SaveStyle := GetWindowLong(ParentCtrl.Handle, GWL_STYLE);
      if(SaveStyle and WS_CLIPCHILDREN) = 0
      then SetWindowLong(ParentCtrl.Handle, GWL_STYLE,
             SaveStyle or WS_CLIPCHILDREN)
      else SaveStyle := 0;
    end
    else SaveStyle := 0;

    if Assigned(RenderWindow) then
    begin
      if Order then
        SetChildOrderAfter(RenderWindow, Ctrl);
      RenderWindow.BoundsRect := Bounds;

      Data.Width        := RenderWindow.Width;
      Data.Height       := RenderWindow.Height;
      Data.DeviceCanvas := RenderWindow.Canvas;

      if ParentCtrl = nil
      then
      begin
        if(not OpeningForm) and (ClipRgn = 0) then
        begin
          ClipRgn := CreateRectRgn(0, 0, 0, 0);
          if GetWindowRgn(TWinControl(Ctrl).Handle, ClipRgn) = ERROR then
          begin
            DeleteObject(ClipRgn);
            ClipRgn := 0;
          end;
        end;

        Flags := SWP_SHOWWINDOW or SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE;
        SetWindowPos(RenderWindow.Handle,
          GetWindow(TWinControl(Ctrl).Handle, GW_HWNDPREV), 0, 0, 0, 0, Flags);
        if OpeningForm and (SrcImage <> nil)then // To reduce flickering when layered windows underneath
          BitBlt(Data.DeviceCanvas.Handle, 0, 0, RenderWindow.Width,
            RenderWindow.Height, SrcImage.Canvas.Handle, 0, 0, cmSrcCopy);
      end
      else ShowWindow(RenderWindow.Handle, SW_SHOWNA);

      Data.DeviceWnd := RenderWindow.Handle;

      ValidateRect(RenderWindow.Handle, nil); // We don't want to receive WM_PAINT
    end
    else Data.DeviceWnd := TForm(Ctrl).Handle;

    FFrozen := True;
  except
    on Exception do
    begin
      Defrost;
      raise;
    end;
  end;
  Result := FFrozen;
end;

function TTEVCLScreenTrDevice.PixelFormat: TPixelFormat;
begin
  Result := DevicePixelFormat(False);
end;

function TTEVCLScreenTrDevice.Prepare(Ctrl: TControl; R: TRect): Boolean;
var
  auxR: TRect;
  NeedSrcBmp: Boolean;
begin
  if TransitionToUse = nil then
    raise ETransitionEffectError.Create(rsTEDevTrIsNil);

  Result := False;

  if Prepared then
    UnPrepare;

  if not AllowTransition then
    exit;

  try
    if OpeningForm and (not Frozen) then
      SaveCtrl := Ctrl; // Needed for GetDelegateTransition

    if Data = nil then
      Initialize;

    Data.Width  := R.Right  - R.Left;
    Data.Height := R.Bottom - R.Top;

    NeedSrcBmp :=
      tetiNeedSrcBmp in TTransitionEffectHack(DelegateTransition).GetInfo(Self);

    if(not TEVclScrPrepared)      and
      OpeningForm                 and
      NeedSrcBmp                  and
      (TEWinVersion >= teWin2000) then
    begin // To avoid problems with layered windows underneath
      auxR       := Ctrl.BoundsRect;
      auxR.Right :=
        auxR.Left + TTransitionEffectHack(DelegateTransition).GetBitmapsWidth(Data);
      SrcImage   :=
        GetSnapShotImage(auxR,
          TTransitionEffectHack(DelegateTransition).GetPixelFormat(Self), True);
    end;

    if not Freeze(Ctrl, R) then
      exit;

    FPrepared        := True;
    TEVclScrPrepared := True;

    if NeedSrcBmp and (SrcImage = nil) then
    begin
      if(not DelegateTransition.NeverRendering) and
        (
          DelegateTransition.ForceRendering or