Recent

Author Topic: drag-drop shape  (Read 4652 times)

NoReason

  • New Member
  • *
  • Posts: 21
drag-drop shape
« on: November 06, 2017, 12:42:53 pm »
need help how to with left click drag shape where i want.

howardpc

  • Hero Member
  • *****
  • Posts: 4144
Re: drag-drop shape
« Reply #1 on: November 06, 2017, 02:05:03 pm »
Open a new Lazarus project, and save it in a new directory. Double-click the empty form to generate an OnCreate handler, and complete as follows:
Code: Pascal  [Select][+][-]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Forms, Controls, Graphics, ExtCtrls;
  9.  
  10. type
  11.  
  12.   TForm1 = class(TForm)
  13.     procedure FormCreate(Sender: TObject);
  14.   private
  15.     const
  16.       ShapeDim = 30;
  17.   private
  18.     FShape: TShape;
  19.     FDropPanel: TPanel;
  20.     procedure PanelDragDrop(Sender, Source: TObject; X, Y: Integer);
  21.     procedure PanelDragOver(Sender, Source: TObject; {%H-}X, {%H-}Y: Integer;
  22.       {%H-}State: TDragState; var Accept: Boolean);
  23.   end;
  24.  
  25. var
  26.   Form1: TForm1;
  27.  
  28. implementation
  29.  
  30. {$R *.lfm}
  31.  
  32. procedure TForm1.FormCreate(Sender: TObject);
  33. begin
  34.   FShape:=TShape.Create(Self);
  35.   with FShape do begin
  36.     SetBounds(10, 10, ShapeDim, ShapeDim);
  37.     Brush.Color:=clYellow;
  38.     Shape:=stCircle;
  39.     DragMode:=dmAutomatic;
  40.     Parent:=Self;
  41.   end;
  42.   FDropPanel:=TPanel.Create(Self);
  43.   with FDropPanel do begin
  44.     SetBounds(80, 30, 200, 200);
  45.     Color:=clMoneyGreen;
  46.     Caption:='DropPanel';
  47.     OnDragOver:=@PanelDragOver;
  48.     OnDragDrop:=@PanelDragDrop;
  49.     Parent:=Self;
  50.   end;
  51. end;
  52.  
  53. procedure TForm1.PanelDragDrop(Sender, Source: TObject; X, Y: Integer);
  54. begin
  55.   if (Source is TShape) and (Sender is TPanel) then begin
  56.     TShape(Source).SetBounds(X, Y, ShapeDim, ShapeDim);
  57.     TShape(Source).Parent:=TPanel(Sender);
  58.   end;
  59. end;
  60.  
  61. procedure TForm1.PanelDragOver(Sender, Source: TObject; X, Y: Integer;
  62.   State: TDragState; var Accept: Boolean);
  63. begin
  64.   if (Source is TShape) then
  65.     Accept:=True;
  66. end;
  67.  
  68. end.

NoReason

  • New Member
  • *
  • Posts: 21
Re: drag-drop shape
« Reply #2 on: November 06, 2017, 02:41:53 pm »
TY but is it possible DropPanel be whole form1 without adding panel?

howardpc

  • Hero Member
  • *****
  • Posts: 4144
Re: drag-drop shape
« Reply #3 on: November 06, 2017, 04:02:00 pm »
Yes. In this case generate OnDragOver and OnDragDrop handlers for the form. The code is almost identical:
Code: Pascal  [Select][+][-]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Forms, Controls, Graphics, ExtCtrls;
  9.  
  10. type
  11.  
  12.   { TForm1 }
  13.  
  14.   TForm1 = class(TForm)
  15.     procedure FormCreate(Sender: TObject);
  16.     procedure FormDragDrop(Sender, Source: TObject; X, Y: Integer);
  17.     procedure FormDragOver(Sender, Source: TObject; {%H-}X, {%H-}Y: Integer;
  18.       {%H-}State: TDragState; var Accept: Boolean);
  19.   private
  20.     const
  21.       ShapeDim = 30;
  22.   private
  23.     FShape: TShape;
  24.   end;
  25.  
  26. var
  27.   Form1: TForm1;
  28.  
  29. implementation
  30.  
  31. {$R *.lfm}
  32.  
  33. procedure TForm1.FormCreate(Sender: TObject);
  34. begin
  35.   FShape:=TShape.Create(Self);
  36.   with FShape do begin
  37.     SetBounds(10, 10, ShapeDim, ShapeDim);
  38.     Brush.Color:=clYellow;
  39.     Shape:=stCircle;
  40.     DragMode:=dmAutomatic;
  41.     Parent:=Self;
  42.   end;
  43. end;
  44.  
  45. procedure TForm1.FormDragDrop(Sender, Source: TObject; X, Y: Integer);
  46. begin
  47.   if (Source is TShape) and (Sender is TForm1) then begin
  48.     TShape(Source).SetBounds(X, Y, ShapeDim, ShapeDim);
  49.     TShape(Source).Parent:=TForm1(Sender);
  50.   end;
  51. end;
  52.  
  53. procedure TForm1.FormDragOver(Sender, Source: TObject; X, Y: Integer;
  54.   State: TDragState; var Accept: Boolean);
  55. begin
  56.   if (Source is TShape) then
  57.     Accept:=True;
  58. end;
  59.  
  60. end.

Handoko

  • Hero Member
  • *****
  • Posts: 5131
  • My goal: build my own game engine using Lazarus
Re: drag-drop shape
« Reply #4 on: November 06, 2017, 05:55:13 pm »
Let's me try. Mine does not use the built-in drag & drop feature. It does not mean to be better, I just want to try use different way to do the same thing.

Code: Pascal  [Select][+][-]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  9.   ExtCtrls;
  10.  
  11. type
  12.  
  13.   { TForm1 }
  14.  
  15.   TForm1 = class(TForm)
  16.     Label1: TLabel;
  17.     Shape1: TShape;
  18.     Shape2: TShape;
  19.     procedure Shape1MouseDown(Sender: TObject; Button: TMouseButton;
  20.       Shift: TShiftState; X, Y: Integer);
  21.     procedure Shape1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer
  22.       );
  23.     procedure Shape1MouseUp(Sender: TObject; Button: TMouseButton;
  24.       Shift: TShiftState; X, Y: Integer);
  25.   private
  26.     function isInsideTheBox(X, Y: Integer): Boolean;
  27.   end;
  28.  
  29. var
  30.   Form1: TForm1;
  31.   isLeftClicking: Boolean = False;
  32.   orgX, orgY: Integer;
  33.  
  34. implementation
  35.  
  36. {$R *.lfm}
  37.  
  38. { TForm1 }
  39.  
  40. procedure TForm1.Shape1MouseDown(Sender: TObject; Button: TMouseButton;
  41.   Shift: TShiftState; X, Y: Integer);
  42. begin
  43.   if (Button <> mbLeft) then Exit;
  44.   orgX := X;
  45.   orgY := Y;
  46.   isLeftClicking := True;
  47. end;
  48.  
  49. procedure TForm1.Shape1MouseMove(Sender: TObject; Shift: TShiftState; X,
  50.   Y: Integer);
  51. begin
  52.   if not(isLeftClicking) then Exit;
  53.   Shape1.Left := Shape1.Left + X-orgX;
  54.   Shape1.Top  := Shape1.Top  + Y-orgY;
  55.   if isInsideTheBox
  56.       (Shape1.Left + Shape1.Width div 2, Shape1.Top + Shape1.Height div 2) then
  57.     Shape1.Brush.Color := clGreen
  58.   else
  59.     Shape1.Brush.Color := clRed;
  60. end;
  61.  
  62. procedure TForm1.Shape1MouseUp(Sender: TObject; Button: TMouseButton;
  63.   Shift: TShiftState; X, Y: Integer);
  64. begin
  65.   if (Shape1.Brush.Color = clGreen) then Halt;
  66.   Shape1.Brush.Color := clSkyBlue;
  67.   isLeftClicking     := False;
  68. end;
  69.  
  70. function TForm1.isInsideTheBox(X, Y: Integer): Boolean;
  71. begin
  72.   Result := True;
  73.   if (X < Shape2.Left) or (X > Shape2.Left + Shape2.Width) or
  74.     (Y < Shape2.Top) or (Y > Shape2.Top + Shape2.Height) then
  75.       Result := False;
  76. end;
  77.  
  78. end.

 

TinyPortal © 2005-2018