Leanback

[Peter666]

Delphi-Quellcode:

unit FMX.TilesGrid;

interface

uses System.SysUtils, System.Classes, System.Types, System.UITypes,
  FMX.Graphics, FMX.Types, FMX.Controls, FMX.Layouts;

type
    TTileItem = class(TControl)
  protected
    FZoomFactor: Single;
    FBackgroundColor: TAlphaColor;

    procedure Paint; override;
    procedure DoEnter; override;
    procedure DoExit; override;

    procedure SetZoomFactor(AValue: Single);
    procedure SetBackgroundColor(AValue: TAlphaColor);

    function GetBarPos: Single;
    procedure SetBarPos(const AValue: Single);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property BackgroundColor: TAlphaColor read FBackgroundColor
      write SetBackgroundColor;
    property ZoomFactor: Single read FZoomFactor write SetZoomFactor;
    property BarPos: Single read GetBarPos write SetBarPos;
  end;

implementation

uses FMX.Ani, FMX.Stdctrls;

const
  cZoomIn = 0.9;
  cZoomOut = 1.0;
  cZoomTime = 0.2;

type TCustomScrollBoxCracker = class(TCustomScrollBox);

constructor TTileItem.Create(AOwner: TComponent);
begin
  inherited;
  CanFocus := true;
  ZoomFactor := 0;
  FBackgroundColor := TAlphaColors.Gray;
end;

destructor TTileItem.Destroy;
begin
  inherited;
end;

function TTileItem.GetBarPos: Single;
begin
  if Owner is TCustomScrollBox then
   result := TCustomScrollBoxCracker(Owner).HScrollBar.Value else
   result := 0;
end;

procedure TTileItem.SetBarPos(const AValue: Single);
begin
  if Owner is TCustomScrollBox then
    TCustomScrollBoxCracker(Owner).HScrollBar.Value := AValue;
end;

procedure TTileItem.DoEnter;
var
 NewScrollViewPos: single;
 MinWidth, MinHeight: Single;
begin
  BringToFront;
  TAnimator.AnimateFloat(self, 'ZoomFactor', cZoomOut, cZoomTime,
    TAnimationType.Out, TInterpolationType.Quadratic);

   NewScrollViewPos := BarPos;
    MinWidth := 0;
    MinHeight := 0;
   if (BoundsRect.Left - NewScrollViewPos < MinWidth) then
    NewScrollViewPos := BoundsRect.Left;

   if (BoundsRect.Left - NewScrollViewPos < MinHeight) then
    NewScrollViewPos := BoundsRect.Right - TCustomScrollBox(Owner).Width;

   if (BoundsRect.Right - NewScrollViewPos > TCustomScrollBox(Owner).Width) then
    NewScrollViewPos := BoundsRect.Right - TCustomScrollBox(Owner).Width;

   TAnimator.AnimateFloat(self, 'BarPos', NewScrollViewPos, cZoomTime,
    TAnimationType.In, TInterpolationType.Linear);
end;

procedure TTileItem.DoExit;
begin
  SendToBack;
  TAnimator.AnimateFloat(self, 'ZoomFactor', cZoomIn, cZoomTime,
    TAnimationType.In, TInterpolationType.Linear);
end;

procedure TTileItem.SetBackgroundColor(AValue: TAlphaColor);
begin
  if FBackgroundColor <> AValue then
  begin
    FBackgroundColor := AValue;
    repaint;
  end;
end;

procedure TTileItem.SetZoomFactor(AValue: Single);
begin
  if AValue < cZoomIn then
    AValue := cZoomIn;
  if AValue > cZoomOut then
    AValue := cZoomOut;

  if FZoomFactor <> AValue then
  begin
    FZoomFactor := AValue;
    repaint;
  end;
end;

procedure TTileItem.Paint;
var
  w, h: Single;
  R: TRectF;

begin
  if Locked then
    Exit;

  w := Width * FZoomFactor;
  h := Height * FZoomFactor;
  R := RectF((Width - w) / 2, (Height - h) / 2, w, h);

  Canvas.Fill.Color := FBackgroundColor;
  Canvas.FillRect(R, 5, 5, AllCorners, AbsoluteOpacity);
end;

end.

Ich hab das jetzt wie folgt gemacht. Das DoEnter macht den ganzen "magischen" Kram. So richtig schön finde ich das mit den Scrollen nicht, aber es geht. @Rollo: Vielleicht hast du ja eine bessere Idee.

Peter