アイテムをドラッグできる ListBox

PK.GUI.DraggableItemListBox.pas

(*
 * アイテムをドラッグできる ListBox
 *
 * PLATFORMS
 *   Windows, macOS, Android, iOS
 *
 * ENVIRONMENT
 *   11.x, 12.x
 *
 * LICENSE
 *   Copyright (c) 2023 HOSOKAWA Jun
 *   Released under the MIT license
 *   http://opensource.org/licenses/mit-license.php
 *
 * HISTORY
 *   2023/07/31 Version 1.0.0
 *
 * Programmed by HOSOKAWA Jun (twitter: @pik)
 *)

unit PK.GUI.DraggableItemListBox;

interface

uses
  System.Classes
  , System.Types
  , System.UITypes
  , FMX.ListBox
  ;

type
  TDraggableItemListBox = class(TCustomListBox)
  public type
    TOnDropItemEvent =
      procedure (
        Sender: TObject;
        const AItem: TListBoxItem;
        const AOldIndex, ANewIndex: Integer) of object;
  private const
    MOVE_THREASHOLD = 8;
  private var
    FDraggable: Boolean;
    FMobileDragging: Boolean;
    FMoveThreashold: Single;
    FOnDropItem: TOnDropItemEvent;
  protected
    procedure MouseDown(
      AButton: TMouseButton;
      AShift: TShiftState;
      AX, AY: Single); override;
    procedure MouseMove(
      AShift: TShiftState;
      AX, AY: Single); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property MoveThreashold: Single read FMoveThreashold write FMoveThreashold;
    property OnDropItem: TOnDropItemEvent read FOnDropItem write FOnDropItem;
  published
    // inherited properties
    property Align;
    property AlternatingRowBackground;
    property Anchors;
    property CanFocus;
    property CanParentFocus;
    property ClipChildren;
    property ClipParent;
    property Columns;
    property Cursor;
    property DisableFocusEffect;
    property DragMode;
    property EnableDragHighlight;
    property Enabled;
    property Locked;
    property Height;
    property HitTest;
    property Hint;
    property ItemIndex;
    property ItemHeight;
    property Items;
    property ItemWidth;
    property Images;
    property DefaultItemStyles;
    property GroupingKind;
    property ListStyle;
    property Padding;
    property MultiSelectStyle;
    property Opacity;
    property Margins;
    property PopupMenu;
    property Position;
    property RotationAngle;
    property RotationCenter;
    property Scale;
    property Size;
    property ShowCheckboxes;
    property Sorted;
    property StyleLookup;
    property TabOrder;
    property TabStop;
    property Visible;
    property Width;
    property ParentShowHint;
    property ShowHint;
    // inherited Events
    property OnApplyStyleLookup;
    property OnChange;
    property OnChangeCheck;
    property OnCompare;
    property OnDragChange;
    property OnDragEnter;
    property OnDragLeave;
    property OnDragOver;
    property OnDragDrop;
    property OnDragEnd;
    property OnKeyDown;
    property OnKeyUp;
    property OnCanFocus;
    property OnItemClick;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnPainting;
    property OnPaint;
    property OnResize;
    property OnResized;
  end;

implementation

uses
  FMX.Platform
  ;

{ TDraggableItemListBox }

constructor TDraggableItemListBox.Create(AOwner: TComponent);
begin
  inherited;

  AllowDrag := True;
  FMoveThreashold := MOVE_THREASHOLD;
  FDraggable :=
    TPlatformServices.Current.SupportsPlatformService(IFMXDragDropService);
end;

procedure TDraggableItemListBox.MouseDown(
  AButton: TMouseButton;
  AShift: TShiftState;
  AX, AY: Single);
begin
  if FDraggable then
  begin
    AllowDrag := False;
    try
      inherited;
    finally
      AllowDrag := True;
    end;
  end
  else
    inherited;

  FMobileDragging := False;
end;

procedure TDraggableItemListBox.MouseMove(AShift: TShiftState; AX, AY: Single);
begin
  inherited;

  // LButton が押されている &
  // 押されている Item がある &
  // モバイルでドラッグ中 or 閾値以上動いたか
  if
    Pressed and
    (ItemDown <> nil) and
    (
      (FMobileDragging) or
      (PressedPosition.Distance(PointF(AX, AY)) > FMoveThreashold)
    )
  then
  begin
    // MouseDown されている Item を示す ItemDown プロパティをローカル変数に入れる
    //（入れなくても良い）
    var Item := ItemDown;

    // 以前の Index を覚えて置く
    var OldIndex := Item.Index;

    if FDraggable then
    begin
      // AllowDrag が有効な場合 (Windows / macOS)

      // アニメーション中なら止める
      AniCalculations.MouseLeave;

      // Drag & Drop 開始
      try
        var Screenshot := Item.MakeScreenshot;
        try
          // IRoot の BeginInternalDrag メソッドを呼ぶとドラッグ動作が始まる
          Root.BeginInternalDrag(Selected, Screenshot);
        finally
          Screenshot.Free;
        end;
      finally
        // BeginInternalDrag の中で既に MouseUp されてしまっているため
        // MouseDown - MouseUp のペアが正しくなるように、ここで強制的に呼ぶ
        MouseUp(TMouseButton.mbLeft, AShift, AX, AY);
      end;
    end
    else
    begin
      // AllowDrag が無効な場合 (Android / iOS)

      // 現在位置に Item があるか？
      // あった場合、ItemDown の Item と同じか？
      var Target := ItemByPoint(AX, AY);
      if (Item = Target) or (Target = nil) then
        Exit;

      /// ドラッグ中フラグを立てて連続的に MouseMove に入るようにする
      FMobileDragging := True;

      // 現在位置の Item と MouseDown 時の Item を入れ替える
      var TargetSelected := Target.IsSelected;
      Content.Exchange(Item, Target);
      SelectionController.SetSelected(Item, True);
      SelectionController.SetSelected(Target, TargetSelected);
    end;

    // 古い Index と新しい Index が別の物だったらイベントを呼ぶ
    var NewIndex :=  Item.Index;
    if (OldIndex <> NewIndex) and Assigned(FOnDropItem) then
      FOnDropItem(Self, Item, OldIndex, NewIndex);
  end;
end;

end.