Pull To Refresh for Delphi

PK.GUI.PullToRefreshLayout.pas

(*
 * PullToRefresh Helper Layout
 *
 * PLATFORMS
 *   Windows / macOS / Android / iOS / Linux
 *
 * LICENSE
 *   Copyright (c) 2019 HOSOKAWA Jun
 *   Released under the MIT license
 *   http://opensource.org/licenses/mit-license.php
 *
 * HISTORY
 *   2019/10/04 Version 1.0.0
 *
 * SAMPLE CODE
 *   FP2RLayout := TPullToRefreshLayout.Create(Self); // Create
 *   FP2RLayout.MaxPullingLen := 80; // Max Pulling Length
 *
 *   FP2RLayout.BoundsRect := Layout1.BoundsRect; // Layout1.Align = Top
 *   FP2RLayout.Parent := Self; // Self is TForm
 *   FP2RLayout.BringToFront; // Show Top
 *
 *   Path1.Parent := FP2RLayout; // Path1 show refresh icon
 *   FP2RLayout.OnRefresh := P2RLayoutRefresh; // Event Handler
 *
 * Programmed by HOSOKAWA Jun (twitter: @pik)
 *)

unit PK.GUI.PullToRefreshLayout;

interface

uses
  System.SysUtils
  , System.Types
  , System.UITypes
  , System.Classes
  , FMX.Types
  , FMX.Layouts
  , FMX.Ani
  ;

type
  TPullToRefreshLayout = class(TLayout)
  public type
    TProcessEvent = procedure (Sender: TObject; Opacity: Single) of object;
  private var
    FReturnAni: TFloatAnimation;
    FPulling: Boolean;
    FStartPosY: Single;
    FOrgPositionY: Single;
    FOrgMarginTop: Single;
    FRefresh: Boolean;
    FMouseService: IFMXMouseService;
  private var
    FMaxPullingLen: Single;
    FOnRefresh: TNotifyEvent;
    FOnStart: TNotifyEvent;
    FOnEnd: TNotifyEvent;
    FOnProcess: TProcessEvent;
  private
    function MouseY(const iDefY: Single): Single;
    procedure ReturnAniProcess(Sender: TObject);
    procedure ReturnAniFinish(Sender: TObject);
    procedure SetMaxPullingLen(const Value: Single);
  protected
    procedure MouseDown(
      iButton: TMouseButton;
      iShift: TShiftState;
      iX, iY: Single); override;
    procedure MouseMove(
      iShift: TShiftState;
      iX, iY: Single); override;
    procedure MouseUp(
      iButton: TMouseButton;
      iShift: TShiftState;
      iX, iY: Single); override;
  public
    constructor Create(iOwner: TComponent); override;
    destructor Destroy; override;
  public
    property MaxPullingLen: Single read FMaxPullingLen write SetMaxPullingLen;
    property OnRefresh: TNotifyEvent read FOnRefresh write FOnRefresh;
    property OnStart: TNotifyEvent read FOnStart write FOnStart;
    property OnEnd: TNotifyEvent read FOnEnd write FOnEnd;
    property OnProcess: TProcessEvent read FOnProcess write FOnProcess;
  end;

implementation

uses
  FMX.Platform;

{ TPullToRefreshLayout }

constructor TPullToRefreshLayout.Create(iOwner: TComponent);
begin
  inherited;

  if
    not TPlatformServices.Current.SupportsPlatformService(
      IFMXMouseService,
      FMouseService)
  then
    FMouseService := nil;

  FMaxPullingLen := 100;

  FReturnAni := TFloatAnimation.Create(Self);
  FReturnAni.Parent := Self;
  FReturnAni.Duration := 0.1;
  FReturnAni.OnProcess := ReturnAniProcess;
  FReturnAni.OnFinish := ReturnAniFinish;

  HitTest := True;
  AutoCapture := True;
  Opacity := 0;
end;

destructor TPullToRefreshLayout.Destroy;
begin
  FReturnAni.Stop;
  FReturnAni.DisposeOf;

  inherited;
end;

procedure TPullToRefreshLayout.MouseDown(
  iButton: TMouseButton;
  iShift: TShiftState;
  iX, iY: Single);
begin
  if iButton = TMouseButton.mbLeft then
  begin
    FOrgPositionY := Position.Y;
    FOrgMarginTop := Margins.Top;
    FStartPosY := MouseY(iY);
    FPulling := True;
  end;

  if Assigned(FOnStart) then
    FOnStart(Self);

  inherited;
end;

procedure TPullToRefreshLayout.MouseMove(iShift: TShiftState; iX, iY: Single);

  function CheckMax(const iY: Single): Single;
  begin
    if (FMaxPullingLen <> 0) and (iY > FMaxPullingLen) then
      Result := FMaxPullingLen
    else
      Result := iY;
  end;

begin
  if not FPulling then
    Exit;

  inherited;

  var DY := MouseY(iY) - FStartPosY;
  if DY < 0 then
    DY := 0;

  if Align = TAlignLayout.None then
    Position.Y := CheckMax(FOrgPositionY + DY)
  else
    Margins.Top := CheckMax(FOrgMarginTop + DY);

  Opacity := DY / FMaxPullingLen;

  if Assigned(FOnProcess) then
    FOnProcess(Self, Opacity);
end;

procedure TPullToRefreshLayout.MouseUp(
  iButton: TMouseButton;
  iShift: TShiftState;
  iX, iY: Single);
begin
  inherited;

  if not FPulling then
    Exit;

  FPulling := False;

  if Align = TAlignLayout.None then
  begin
    FReturnAni.PropertyName := 'Position.Y';
    FReturnAni.StartValue := Position.Y;
    FReturnAni.StopValue := FOrgPositionY;
  end
  else
  begin
    FReturnAni.PropertyName := 'Margins.Top';
    FReturnAni.StartValue := Margins.Top;
    FReturnAni.StopValue := FOrgMarginTop;
  end;

  var DY := MouseY(iY) - FStartPosY;

  if DY > 0 then
  begin
    FRefresh := Opacity >= 0.3;
    FReturnAni.Start;
  end
  else
  begin
    Opacity := 0;
    Position.Y := FOrgPositionY;
    Margins.Top := FOrgMarginTop;
  end;

  if Assigned(FOnEnd) then
    FOnEnd(Self);
end;

function TPullToRefreshLayout.MouseY(const iDefY: Single): Single;
begin
  if FMouseService = nil then
    Result := iDefY
  else
    Result := FMouseService.GetMousePos.Y;
end;

procedure TPullToRefreshLayout.ReturnAniFinish(Sender: TObject);
begin
  if FRefresh and Assigned(FOnRefresh) then
    FOnRefresh(Self);

  Opacity := 0;
end;

procedure TPullToRefreshLayout.ReturnAniProcess(Sender: TObject);
begin
  Opacity := 1 - FReturnAni.CurrentTime / FReturnAni.Duration;
end;

procedure TPullToRefreshLayout.SetMaxPullingLen(const Value: Single);
begin
  if Value <= 0 then
    Exit;

  FMaxPullingLen := Value;
end;

end.