Author: Tomas Rutkauskas
How to make a dynamically created TLabel draggable
Answer:
Create a new project with an empty form, add StdCtls to the Uses clause (for the
TLabel class, you can also add a single label at design time). Add a handler to the
forms OnClick method, then modify the unit as below. Compile and run, click on the
form to create a label, drag on a label to move it.
1 unit Unit1;
2
3 interface
4
5 uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 StdCtrls;
8
9 type
10 TForm1 = class(TForm)
11 procedure FormClick(Sender: TObject);
12 private
13 { Private declarations }
14 downX, downY: Integer;
15 dragging: Boolean;
16 procedure ControlMouseDown(Sender: TObject; Button: TMouseButton;
17 Shift: TShiftState; X, Y: Integer);
18 procedure ControlMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
19 procedure ControlMouseUp(Sender: TObject; Button: TMouseButton;
20 Shift: TShiftState; X, Y: Integer);
21 public
22 { Public declarations }
23 end;
24
25 var
26 Form1: TForm1;
27
28 implementation
29
30 {$R *.DFM}
31
32 type
33 TCracker = class(TControl);
34 { Needed since TControl.MouseCapture is protected }
35
36 procedure TForm1.FormClick(Sender: TObject);
37 var
38 pt: TPoint;
39 begin
40 {get cursor position, convert to client coordinates}
41 GetCursorPos(pt);
42 pt := ScreenToClient(pt);
43 {create label with top left corner at mouse position}
44 with TLabel.Create(Self) do
45 begin
46 SetBounds(pt.x, pt.y, width, height);
47 Caption := Format('Hit at %d, %d', [pt.x, pt.y]);
48 Color := clBlue;
49 Font.Color := clWhite;
50 Autosize := true;
51 Parent := Self;
52 {attach the drag handlers}
53 OnMouseDown := ControlMouseDown;
54 OnMouseUp := ControlMouseUp;
55 OnMouseMove := ControlMouseMove;
56 end;
57 end;
58
59 procedure TForm1.ControlMouseDown(Sender: TObject; Button: TMouseButton;
60 Shift: TShiftState; X, Y: Integer);
61 begin
62 downX := X;
63 downY := Y;
64 dragging := TRue;
65 with TCracker(Sender) do
66 begin
67 MouseCapture := True;
68 Color := clRed;
69 end;
70 end;
71
72 procedure TForm1.ControlMouseMove(Sender: TObject; Shift: TShiftState; X, Y:
73 Integer);
74 begin
75 if dragging then
76 with Sender as TControl do
77 begin
78 Left := X - downX + Left;
79 Top := Y - downY + Top;
80 end;
81 end;
82
83 procedure TForm1.ControlMouseUp(Sender: TObject; Button: TMouseButton;
84 Shift: TShiftState; X, Y: Integer);
85 begin
86 if dragging then
87 begin
88 dragging := False;
89 with TCracker(Sender) do
90 begin
91 MouseCapture := False;
92 Color := clBlue;
93 end;
94 end;
95 end;
96
97 end.
|
