Recent

Author Topic: [SOLVED] Almost There... Drag And Drop Animation  (Read 1106 times)

DeBritto

  • Jr. Member
  • **
  • Posts: 68
[SOLVED] Almost There... Drag And Drop Animation
« on: May 09, 2019, 01:58:50 pm »
Hi Folks,
I'm trying to create an "animation" that shows a moving cell of a StringList. Then I discovered that there an example that does almost what I need. The problem is that the code below shows all the control area moving and I need to show the active cell only, not the window area (pls see gif below).
Please, I'm trying to do this but I still don't figure it out. Can you help me with that?
Warm regards,
Chris


Code: Pascal  [Select][+][-]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
  9.   ExtCtrls;
  10.  
  11. type
  12.  
  13.   { TForm1 }
  14.  
  15.   TForm1 = class(TForm)
  16.     Button1: TButton;
  17.     Label1: TLabel;
  18.     Panel1: TPanel;
  19.     procedure Button1StartDrag(Sender: TObject; var DragObject: TDragObject);
  20.     procedure Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
  21.     procedure Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
  22.       State: TDragState; var Accept: Boolean);
  23.   private
  24.     { private declarations }
  25.   public
  26.     { public declarations }
  27.   end;
  28.  
  29.   { TMyDragObject }
  30.  
  31.   TMyDragObject = class(TDragControlObject)
  32.   private
  33.     FDragImages: TDragImageList;
  34.   protected
  35.     function GetDragImages: TDragImageList; override;
  36.   public
  37.     constructor Create(AControl: TControl); override;
  38.     destructor Destroy; override;
  39.   end;
  40.  
  41. var
  42.   Form1: TForm1;
  43.  
  44. implementation
  45.  
  46. {$R unit1.lfm}
  47.  
  48. { TForm1 }
  49.  
  50. procedure TForm1.Button1StartDrag(Sender: TObject; var DragObject: TDragObject);
  51. begin
  52.   // user started dragging on Button1
  53.   // create our own TDragControlObject which provides an image.
  54.   DragObject := TMyDragObject.Create(Sender as TControl);
  55. end;
  56.  
  57. procedure TForm1.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
  58. begin
  59.   ShowMessage('Congratulations. You dropped button on me :)')
  60. end;
  61.  
  62. procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
  63.   State: TDragState; var Accept: Boolean);
  64. var
  65.   Control: TControl;
  66. begin
  67.   if Source is TControl then
  68.     Control := Source as TControl
  69.   else
  70.   if Source is TDragControlObject then
  71.     Control := (Source as TDragControlObject).Control
  72.   else
  73.     Control := nil;
  74.   Accept := Control is TButton;
  75. end;
  76.  
  77. { TMyDragObject }
  78.  
  79. function TMyDragObject.GetDragImages: TDragImageList;
  80. begin
  81.   Result := FDragImages;
  82. end;
  83.  
  84. constructor TMyDragObject.Create(AControl: TControl);
  85. var
  86.   Bitmap: TBitmap;
  87. begin
  88.   inherited Create(AControl);
  89.   FDragImages := TDragImageList.Create(AControl);
  90.   AlwaysShowDragImages := True;
  91.  
  92.   Bitmap := TBitmap.Create;
  93.   Bitmap.Width := AControl.Width;
  94.   Bitmap.Height := AControl.Height;
  95.   if AControl is TWinControl then
  96.     (AControl as TWinControl).PaintTo(Bitmap.Canvas, 0, 0);
  97.   FDragImages.Width := Bitmap.Width;
  98.   FDragImages.Height := Bitmap.Height;
  99.   FDragImages.Add(Bitmap, nil);
  100.   FDragImages.DragHotspot := Point(Bitmap.Width, Bitmap.Height);
  101.   Bitmap.Free;
  102. end;
  103.  
  104. destructor TMyDragObject.Destroy;
  105. begin
  106.   FDragImages.Free;
  107.   inherited Destroy;
  108. end;
  109.  
  110. end.
  111.  
  112.  
« Last Edit: May 10, 2019, 07:48:53 pm by DeBritto »

Handoko

  • Hero Member
  • *****
  • Posts: 3547
  • My goal: build my own game engine using Lazarus
Re: Almost There... Drag And Drop Animation
« Reply #1 on: May 09, 2019, 02:41:25 pm »
(pls see gif below).

Where is the gif you mentioned?
I have problem finding it. %)

Not really sure what you want, your code seems to work on my test.

DeBritto

  • Jr. Member
  • **
  • Posts: 68
Re: Almost There... Drag And Drop Animation
« Reply #2 on: May 09, 2019, 04:25:39 pm »
Hi @Handoko,
I'm so Sorry. I forgot to upload the gif. It is fixed now.
Can you help me?
Warm Regards,
Chris

Handoko

  • Hero Member
  • *****
  • Posts: 3547
  • My goal: build my own game engine using Lazarus
Re: Almost There... Drag And Drop Animation
« Reply #3 on: May 09, 2019, 04:34:26 pm »
Can you provide the source code? I need the source code to test and to understand the issue. If you're not willing to publicize it, you can create a demo that showing the issue.

To attach the source code to the forum:
Create a new folder, copy and paste all the necessary files except: the binary (exe file), *.bak, lib and backup folders. Compress the folder and send the zip here.

DeBritto

  • Jr. Member
  • **
  • Posts: 68
Re: Almost There... Drag And Drop Animation
« Reply #4 on: May 09, 2019, 09:44:53 pm »
Hi @Handoko,

I've created an example that simulates the issue. As you'll see when you start to drag one StringGrid cell the Bitmap of all the StringGrid control is painted. What I need is the Bitmap of the specific cell that is being dragged only.
Best Regards,
Chris

jamie

  • Hero Member
  • *****
  • Posts: 3116
Re: Almost There... Drag And Drop Animation
« Reply #5 on: May 09, 2019, 11:02:16 pm »
I believe you can make a Cursor from a bitmap. assign that cursor to the list using an unused index..

The cursors are in the "Screens" class

In the stringgrid you need to update this cursor each time you get reading to do a drag operation, the image
would be that of the CELL.
Here is some example of loading it from a file. in your case you would get it from the cell.

http://delphi.cjcsoft.net/viewthread.php?tid=49594

You may even be able to use TIcon to do the same..






The only true wisdom is knowing you know nothing

DeBritto

  • Jr. Member
  • **
  • Posts: 68
Re: Almost There... Drag And Drop Animation
« Reply #6 on: May 09, 2019, 11:20:44 pm »
Hi @Jamie,
Very good idea! The only issue is that the other solution gives me a bitmap with the real content of the cell, and this other option I'll have a standard bitmap.
Best regards
« Last Edit: May 10, 2019, 12:06:10 am by DeBritto »

Handoko

  • Hero Member
  • *****
  • Posts: 3547
  • My goal: build my own game engine using Lazarus
Re: Almost There... Drag And Drop Animation
« Reply #7 on: May 10, 2019, 05:01:13 am »
I improved your code (added lines #108 - #119). It still has some minor issues but I believe you can fix them to achieve exactly what you want:

Code: Pascal  [Select][+][-]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
  9.   ExtCtrls, Grids;
  10.  
  11. type
  12.  
  13.   { TForm1 }
  14.  
  15.   TForm1 = class(TForm)
  16.     Button1: TButton;
  17.     Panel1: TPanel;
  18.     StringGrid1: TStringGrid;
  19.     procedure Button1StartDrag(Sender: TObject; var DragObject: TDragObject);
  20.     procedure Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
  21.     procedure Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
  22.       State: TDragState; var Accept: Boolean);
  23.     procedure StringGrid1StartDrag(Sender: TObject; var DragObject: TDragObject
  24.       );
  25.   private
  26.     { private declarations }
  27.   public
  28.     { public declarations }
  29.   end;
  30.  
  31.   { TMyDragObject }
  32.  
  33.   TMyDragObject = class(TDragControlObject)
  34.   private
  35.     FDragImages: TDragImageList;
  36.   protected
  37.     function GetDragImages: TDragImageList; override;
  38.   public
  39.     constructor Create(AControl: TControl); override;
  40.     destructor Destroy; override;
  41.   end;
  42.  
  43. var
  44.   Form1: TForm1;
  45.  
  46. implementation
  47.  
  48. {$R unit1.lfm}
  49.  
  50. { TForm1 }
  51.  
  52. procedure TForm1.Button1StartDrag(Sender: TObject; var DragObject: TDragObject);
  53. begin
  54.   // user started dragging on Button1
  55.   // create our own TDragControlObject which provides an image.
  56.   DragObject := TMyDragObject.Create(Sender as TControl);
  57. end;
  58.  
  59. procedure TForm1.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
  60. begin
  61.   ShowMessage('Congratulations. You dropped button on me :)')
  62. end;
  63.  
  64. procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
  65.   State: TDragState; var Accept: Boolean);
  66. var
  67.   Control: TControl;
  68. begin
  69.   if Source is TControl then
  70.     Control := Source as TControl
  71.   else
  72.   if Source is TDragControlObject then
  73.     Control := (Source as TDragControlObject).Control
  74.   else
  75.     Control := nil;
  76.   Accept := Control is TButton;
  77. end;
  78.  
  79. procedure TForm1.StringGrid1StartDrag(Sender: TObject;
  80.   var DragObject: TDragObject);
  81. begin
  82.    DragObject := TMyDragObject.Create(Sender as TControl);
  83. end;
  84.  
  85. { TMyDragObject }
  86.  
  87. function TMyDragObject.GetDragImages: TDragImageList;
  88. begin
  89.   Result := FDragImages;
  90. end;
  91.  
  92. constructor TMyDragObject.Create(AControl: TControl);
  93. var
  94.   ARect   : TRect;
  95.   Bitmap  : TBitmap;
  96.   Cropped : TBitmap;
  97. begin
  98.   inherited Create(AControl);
  99.   FDragImages := TDragImageList.Create(AControl);
  100.   AlwaysShowDragImages := True;
  101.  
  102.   Bitmap := TBitmap.Create;
  103.   Bitmap.Width := AControl.Width;
  104.   Bitmap.Height := AControl.Height;
  105.   if AControl is TWinControl then
  106.     (AControl as TWinControl).PaintTo(Bitmap.Canvas, 0, 0);
  107.  
  108.   if AControl is TStringGrid then
  109.   begin
  110.     with (AControl as TStringGrid) do
  111.       ARect := CellRect(Col, Row);
  112.     Cropped := TBitmap.Create;
  113.     Cropped.SetSize(ARect.Width, ARect.Height);
  114.     Cropped.Canvas.CopyRect
  115.       (Rect(0, 0, ARect.Width, ARect.Height), Bitmap.Canvas, ARect);
  116.     Bitmap.SetSize(ARect.Width, ARect.Height);
  117.     Bitmap.Canvas.Draw(0, 0, Cropped);
  118.     Cropped.Free;
  119.   end;
  120.  
  121.   FDragImages.Width := Bitmap.Width;
  122.   FDragImages.Height := Bitmap.Height;
  123.   FDragImages.Add(Bitmap, nil);
  124.   FDragImages.DragHotspot := Point(Bitmap.Width, Bitmap.Height);
  125.   Bitmap.Free;
  126. end;
  127.  
  128. destructor TMyDragObject.Destroy;
  129. begin
  130.   FDragImages.Free;
  131.   inherited Destroy;
  132. end;
  133.  
  134. end.

ASerge

  • Hero Member
  • *****
  • Posts: 1615
Re: Almost There... Drag And Drop Animation
« Reply #8 on: May 10, 2019, 08:07:29 am »
1. TDragControlObject is not released automatically, so there is a memory leak. You must inherit from TDragControlObjectEx.
Code: Pascal  [Select][+][-]
  1. TMyDragObject = class(TDragControlObjectEx)

2. Button1StartDrag and StringGrid1StartDrag do the same and can be combined.

3. Hotspot must be set to mouse position.
4. No need to create a separate TBitmap to copy a part of it to the beginning.
5. Grid.Col and Grid.Row may not coincide with the position of the mouse, you need to calculate the grid cell.
Code: Pascal  [Select][+][-]
  1. constructor TMyDragObject.Create(AControl: TControl);
  2. var
  3.   LRect: TRect;
  4.   LBitmap: TBitmap;
  5.   LCanvas: TCanvas;
  6.   StartPos: TPoint;
  7.   GridPos: TGridCoord;
  8. begin
  9.   inherited;
  10.   FDragImages := TDragImageList.Create(Control);
  11.   AlwaysShowDragImages := True;
  12.   StartPos := Control.ScreenToClient(Mouse.CursorPos);;
  13.   LBitmap := TBitmap.Create;
  14.   try
  15.     LBitmap.Width := Control.Width;
  16.     LBitmap.Height := Control.Height;
  17.     LCanvas := LBitmap.Canvas;
  18.     if Control is TWinControl then
  19.       TWinControl(Control).PaintTo(LCanvas, 0, 0);
  20.     if Control is TStringGrid then
  21.     begin
  22.       GridPos := TStringGrid(Control).MouseToCell(StartPos);
  23.       LRect := TStringGrid(Control).CellRect(GridPos.X, GridPos.Y);
  24.       StartPos.Offset(-LRect.Left, -LRect.Top);
  25.       LCanvas.CopyRect(Rect(0, 0, LRect.Width, LRect.Height), LCanvas, LRect);
  26.       LBitmap.Width := LRect.Width;
  27.       LBitmap.Height := LRect.Height;
  28.     end;
  29.     FDragImages.Width := LBitmap.Width;
  30.     FDragImages.Height := LBitmap.Height;
  31.     FDragImages.Add(LBitmap, nil);
  32.     FDragImages.DragHotspot := StartPos;
  33.   finally
  34.     LBitmap.Free;
  35.   end;
  36. end;

6. DragOver can be simplified:
Code: Pascal  [Select][+][-]
  1. procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
  2.   State: TDragState; var Accept: Boolean);
  3. var
  4.   LSource: TObject;
  5. begin
  6.   LSource := Source;
  7.   if LSource is TDragObject then
  8.     LSource := TDragObject(LSource).Control;
  9.   Accept := LSource is TButton;
  10. end;


DeBritto

  • Jr. Member
  • **
  • Posts: 68
Re: Almost There... Drag And Drop Animation
« Reply #9 on: May 10, 2019, 07:48:27 pm »
Hi Folks,

You all are AWESOME!
It's working now. It's because of this that I love Pascal if you have the skills, then you could do awesome things.

I just made some adjustments in order to create a bitmap with cell's content only, i.e. leaving the gridline space behind.

Warm regards,
Guys you rock!

Code: Pascal  [Select][+][-]
  1. constructor TMyDragObject.Create(AControl: TControl);
  2. var
  3.   LRect: TRect;
  4.   LBitmap: TBitmap;
  5.   LCanvas: TCanvas;
  6.   StartPos: TPoint;
  7.   GridPos: TGridCoord;
  8.   LineWidth : Integer;
  9. begin
  10.   inherited;
  11.   FDragImages := TDragImageList.Create(Control);
  12.   AlwaysShowDragImages := True;
  13.   StartPos := Control.ScreenToClient(Mouse.CursorPos);;
  14.   LBitmap := TBitmap.Create;
  15.  
  16.   try
  17.     LBitmap.Width := Control.Width;
  18.     LBitmap.Height := Control.Height;
  19.     LCanvas := LBitmap.Canvas;
  20.  
  21.     if Control is TWinControl then
  22.        TWinControl(Control).PaintTo(LCanvas, 0, 0);
  23.  
  24.     if Control is TStringGrid then
  25.     begin
  26.       GridPos := TStringGrid(Control).MouseToCell(StartPos);
  27.       LRect := TStringGrid(Control).CellRect(GridPos.X, GridPos.Y);
  28.       StartPos.Offset(-LRect.Left, -LRect.Top);
  29.       LCanvas.CopyRect(Rect(0, 0, LRect.Width, LRect.Height), LCanvas, LRect);
  30.       LBitmap.Width := LRect.Width;
  31.       LBitmap.Height := LRect.Height;
  32.     end;
  33.  
  34.     LineWidth := TStringGrid(Control).GridLineWidth div 2;
  35.     FDragImages.Width := LBitmap.Width-LineWidth;
  36.     FDragImages.Height := LBitmap.Height-LineWidth;
  37.     FDragImages.Add(LBitmap, nil);
  38.     FDragImages.DragHotspot := StartPos;
  39.   finally
  40.     LBitmap.Free;
  41.   end;
  42. end;
  43.  

DeBritto

  • Jr. Member
  • **
  • Posts: 68
Re: [SOLVED] Almost There... Drag And Drop Animation
« Reply #10 on: May 10, 2019, 08:07:47 pm »
HI Folks,
You really helped me to accomplish my goal. But I'm thinking if we can push forward a little, something beyond my skills for sure.

Is it possible to paint something on the bitmap of the cell that is being moved, in order to shows if the dragged cell will be dropped  AFTER or BEFORE the source cell?

I don't have a clue on how to do this. Maybe paint a small red arrow at the left or the right of the cell, if its position - compared to the target cell, the one that is below the moving bitmap - is in a far left of the far right position.

Please see the gif attached, just to have an idea.
Warm Regards,
Christian

 

TinyPortal © 2005-2018