Thursday, September 17, 2015

Dragging Rectangles on Firemonkey Form

Delphi DX10 

For the perennial question of how to move objects around the form at run time, here is a method for dragging Rectangles (or any shapes) around on the form with the mouse or touch.

Considerations:

We need a Layout in the background to use as a coordinate system that can be turned on and off. 

We need to set Rectangle.Hittest:= true so we can pick it.

We need to set Layout.Hittest := false to start with or it will interfere with picking the rectangles.

When we pick a rectangle, we need to capture the mouse events of the Layout so we can use the coordinates MouseMove and MouseUp to stop. We will do this with Layout1.Root.Captured := Layout1;

Use the Layout X,Y MouseMove coordinates to move rectangle.

Use Layout MouseUp event to end dragging. Layout mouse capture is turned off and we can pick the next rectangle.


unit File: Mainunit.pas

unit Mainunit;

interface


uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Objects,
  FMX.Layouts, FMX.Controls.Presentation, FMX.StdCtrls;

type
  TMainForm = class(TForm)
    Layout1: TLayout;
    Rectangle1: TRectangle;
    procedure Rectangle1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    procedure Layout1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Single);
    procedure Layout1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation


{$R *.fmx}

const
  MAX_RECTANGLES = 10;
  RECT_WIDTH = 80;
  RECT_HEIGHT = 80;

var
  Grab: boolean = false;
  Offset: tpointf;
  MovingRectangle: TRectangle;
  RectArray: array [0 .. MAX_RECTANGLES] of TRectangle;

procedure TMainForm.FormCreate(Sender: TObject);
var
  I: integer;
  TitleRect: TRectangle;
  TitleLabel: TLabel;
begin
  Layout1.HitTest := false; // want to pick rectangles
  for I := Low(RectArray) to high(RectArray) do
  begin
    RectArray[I] := TRectangle.Create(self);
    RectArray[I].Parent := Layout1;
    RectArray[I].OnMouseDown := Rectangle1MouseDown;
    RectArray[I].OnMouseUp := Layout1MouseUp;
    RectArray[I].Width := RECT_WIDTH;
    RectArray[I].Height := RECT_HEIGHT;
    RectArray[I].fill.Color := random($FFFFFF) or $FF000000;
    RectArray[I].Position.X := random(trunc(Layout1.Width - RECT_WIDTH));
    RectArray[I].Position.Y := random(trunc(Layout1.Height - RECT_HEIGHT));

    TitleRect := TRectangle.Create(self);
    TitleRect.fill.Color := Talphacolorrec.White;
    TitleRect.Position.X := 0;
    TitleRect.Position.Y := 0;
    TitleRect.Width := RECT_WIDTH;
    TitleRect.Height := 16;
    TitleRect.HitTest := false;

    TitleLabel := TLabel.Create(self);
    TitleLabel.StyledSettings:=[];
    TitleLabel.Font.Size:=12;
    TitleLabel.Text := 'Caption ' + I.ToString;
    TitleRect.AddObject(TitleLabel);

    RectArray[I].AddObject(TitleRect);
  end;
end;

procedure TMainForm.Layout1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Single);
begin
  if Grab and (ssleft in Shift) then
  begin
    // keep from dragging off Layout
    if X > (Layout1.Width + Offset.X - RECT_WIDTH) then
      X := Layout1.Width + Offset.X - RECT_WIDTH;
    if Y > (Layout1.Height + Offset.Y - RECT_HEIGHT) then
      Y := Layout1.Height + Offset.Y - RECT_HEIGHT;
    if X < Offset.X then
      X := Offset.X;
    if Y < Offset.Y then
      Y := Offset.Y;

    MovingRectangle.Position.X := X - Offset.X;
    MovingRectangle.Position.Y := Y - Offset.Y;
  end;
end;

procedure TMainForm.Layout1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
  Grab := false;
  // MouseUp automatically turns off mouse capture of Layout1
end;

procedure TMainForm.Rectangle1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
  X, Y: Single);
begin
  MovingRectangle := Sender as TRectangle;
  Offset.X := X;
  Offset.Y := Y;
  // sets mouse capture to Layout1
  Layout1.Root.Captured := Layout1;
  MovingRectangle.BringToFront; // optional
  MovingRectangle.Repaint;
  Grab := true;
end;

end.



FMX File: Mainunit.FMX

object MainForm: TMainForm
  Left = 0
  Top = 0
  BorderIcons = [biSystemMenu, biMinimize]
  BorderStyle = Single
  Caption = 'Form33'
  ClientHeight = 480
  ClientWidth = 640
  FormFactor.Width = 320
  FormFactor.Height = 480
  FormFactor.Devices = [Desktop]
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  DesignerMasterStyle = 0
  object Layout1: TLayout
    Anchors = [akLeft, akTop, akRight, akBottom]
    HitTest =
False    
    Position.X = 30.000000000000000000
    Position.Y = 30.000000000000000000
    Size.Width = 579.000000000000000000
    Size.Height = 421.000000000000000000
    Size.PlatformDefault = False
    TabOrder = 0
    OnMouseMove = Layout1MouseMove
    OnMouseUp = Layout1MouseUp
    object Rectangle1: TRectangle
      Align = Client
      Fill.Color = claAntiquewhite
      HitTest = False
      Size.Width = 579.000000000000000000
      Size.Height = 421.000000000000000000
      Size.PlatformDefault = False
    end
  end
end



DPR File:
program DragRectangles;

uses
  System.StartUpCopy,
  FMX.Forms,
  Mainunit in 'Mainunit.pas' {MainForm};

{$R *.res}

begin
  ReportMemoryLeaksOnShutdown := DebugHook <> 0;
  Application.Initialize;
  Application.CreateForm(TMainForm, MainForm);
  Application.Run;
end.


Works in Windows, OSX, IOS, Android

Download DX10 Source code: DragRectangles.zip

Form Shown on Screens:



You can test when the rectangle you are moving lands on top of another one.
Just replace the TMainForm.Layout1MouseUp procedure with this one:

procedure TMainForm.Layout1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
var
  I: integer;
  BottomRectangle: TRectangle;

  function PointInRect(X, Y { top rect corner coords in layout1 } : Single; BotRect: TRectangle): boolean;
  begin
    if (X >= BotRect.Position.X) and (X <= (BotRect.Position.X + BotRect.Width)) and (Y >= BotRect.Position.Y)
      and (Y <= BotRect.Position.Y + BotRect.Height) then
      result := true
    else
      result := false;
  end;

  function RectangleOnTop(TopRect, BotRect: TRectangle): boolean;
  var
    X1, Y1, X2, Y2, X3, Y3, X4, Y4: Single;
  begin
    // 4 corners
    // 1-------2
    // 3-------4
    result := false;
    X1 := TopRect.Position.X; // these are the four corners according in layout1 coords
    Y1 := TopRect.Position.Y; // of the top moving rect
    X2 := X1 + TopRect.Width;
    Y2 := Y1;
    X3 := X1;
    Y3 := Y1 + TopRect.Height;
    X4 := X2;
    Y4 := Y3;

    // check 4 corners of top rect
    if PointInRect(X1, Y1, BotRect) or PointInRect(X2, Y2, BotRect) or PointInRect(X3, Y3, BotRect) or
      PointInRect(X4, Y4, BotRect) then
      result := true;
  end;

begin
  Grab := false;
  // MouseUp automatically turns off mouse capture of Layout1

  // check to see if over another rectangle
  for I := Low(RectArray) to high(RectArray) do
  begin
    if MovingRectangle <> RectArray[I] then
    begin
      if RectangleOnTop(MovingRectangle, RectArray[I]) then
      begin
        BottomRectangle := RectArray[I];
        beep;
        showmessage('Over Rect ' + TLabel(BottomRectangle.Children.Items[0].Children.Items[0]).Text);
        break;
      end;
    end;
  end;
end;

 

13 comments:

  1. Thanks so much, this is awesome!

    ReplyDelete
  2. Hi Douglas,

    Thanks for an excellent article!!!

    I'v been going through your code with a fine comb trying to understand it.

    In the DPR file I came across something that I have not seen before.

    (1) Why is there a 'System.StartUpCopy' in the uses clause? I could not find any info in the help on this.
    (2) The first line in the program is 'ReportMemoryLeaksOnShutdown ..'. What does this do? Again I did not find any information in the help on it.

    ReplyDelete
    Replies
    1. 'System.StartUpCopy' is automatically put in by Delphi when you start a new Mobile app. It has to do with deploying extra files to the documents directory. In this case it is not being used, its just a leftover that doesn't hurt anything.

      'ReportMemoryLeaksOnShutdown ..'. has been in Delphi forever. It reports memory leaks in a message box at end of program. ':= DebugHook <> 0;' means do it only if debuging in the IDE.
      Try creating some objects in your program and not freeing them, and you will see.

      Delete
  3. This is almost perfect for my application! Thanks so much for posting it. Two questions:

    1. Is there a way to tell if you've dropped one rectangle on another?

    2. Do you have a logo that I can post on my "About" page so I can give credit where credit is due?

    Thanks again!

    ReplyDelete
    Replies
    1. I added at the bottom of the post a change to the procedure to tell when one rectangle lands on top of another.

      Delete
  4. Excellent post! It fit like a glove for my pourposes! I'm looking forward for more posts like this.

    One question:

    The Firemonkey documentation recommends to use SetCaptured for setting the control that is to capture mouse events. Why you choosed not to use it? Also, I failed to use it myself.

    ReplyDelete
  5. Hello, I wanted to ask is there any solution for drag drop listbox items on an android tablet with touch

    ReplyDelete
  6. Berlin an unexpected leak
    1-12 bytes
    TwinAcceleratorKeyRegistery.TacceleratorKeyReceiverX1

    ReplyDelete
  7. Moved
    var
    Grab: boolean = false;
    Offset: tpointf;
    MovingRectangle: TRectangle;
    RectArray: array [0 .. MAX_RECTANGLES] of TRectangle;
    TitleRect: TRectangle; <<<<<

    Added
    procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
    var
    i:Integer;
    begin
    for I := Low(RectArray) to high(RectArray) do
    begin
    RectArray[I].Free;
    TitleRect.Free;
    end;

    end;

    Now no leaks

    ReplyDelete
  8. Ooops my mistake
    take off TitleRect section and it is OK.
    Then how to free TitleRect ?

    ReplyDelete
  9. Finally got it BUT !!

    GLOBAL
    TitleRect: TRectangle;
    TitleLabel: TLabel;

    procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
    var
    i:Integer;
    begin
    TitleLabel.Free;
    TitleRect.Free;
    for I := Low(RectArray) to high(RectArray) do
    begin
    RectArray[I].Free;
    end;
    end;

    BUT !! leak
    // TitleLabel.Text := 'Caption ' + I.ToString;

    ReplyDelete
  10. Hi, Thanks for the sample.

    How can I capture when I click inside the layout but without clicking any rectangle?
    When I click on a rectangle I show a pop-up menu, and I want that when I click where I do not have any rectangles that pop-up window disappears.
    Try the OnClik, OnMouseUp, OnClick Layout, and Rectangle1 event

    ReplyDelete
  11. Hello there. I get the layout1 object into a scrollbox and I'm doing the layout.width: = 1000 and the layout.height: = 1000. When I make a larger field for objects, I move on the scrollbox with android rectangle and I can't move the object. how can I overcome this problem.

    ReplyDelete