Živě.cz o počítačích a internetu

Tipy a triky v Delphi, díl 58. - Posun textu pomocí myši po formuláři

Jan Šindelář - 18.9.2002

Posun textu pomocí myši po formuláři

Poněkud zamlžený úvod si hned podrobněji vysvětlíme. Příklad, který si teď ukážeme, bude dělat jednoduchou věc. Po kliknutí na formulář se na daném místě objeví textový popisek (Label). Tento Label pak budeme moci po formuláři libovolně přesunovat myší ve stylu drag and drop. Takovýchto Labelů si budete moci na formulář "naklikat" kolik budete chtít, protože jsou vytvářeny až za běhu programu.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
  procedure FormClick(Sender: TObject);
private
  { Private declarations }
  downX, downY: Integer;
  dragging: Boolean;
  procedure ControlMouseDown(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
  procedure ControlMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  procedure ControlMouseUp(Sender: TObject; Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer);
public
  { Public declarations }
end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
  TMCapture = Class(TControl);


procedure TForm1.FormClick(Sender: TObject);
var
  pt: TPoint;
begin
  GetCursorPos( pt );
  pt := ScreenToClient( pt );
  with TLabel.Create( Self ) do
    begin
      SetBounds(pt.x, pt.y, width, height);
      Caption := Format(`Souřadnice %d, %d`, [pt.x, pt.y]);
      Color := clBlue;
      Font.Color := clWhite;
      Autosize := True;
      Parent := Self;
      OnMouseDown := ControlMouseDown;
      OnMouseUp := ControlMouseUp;
      OnMouseMove := ControlMouseMove;
    end;
end;

procedure TForm1.ControlMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
  downX := X;
  downY := Y;
  dragging := True;
  with TMCapture(Sender) do
    begin
      MouseCapture := True;
      Color := clRed;
    end;
end;

procedure TForm1.ControlMouseMove(Sender: TObject; Shift: TShiftState;  X, Y: Integer);
begin
  if dragging then
    with Sender as TControl do
    begin
      Left := X - downX + Left;
      Top := Y - downY + Top;
    end;
end;

procedure TForm1.ControlMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
  if dragging then
    begin
      dragging := False;
      with TMCapture(Sender) do
        begin
          MouseCapture := False;
          Color := clBlue;
        end;
    end;
end;

end.

Pro zvýšení "efektu" je barva Labelu během přetahování změněna na červenou (z původní modré). K přesunování textu můžete použít libovolné tlačítko na myši, ale pokud by vám to nevyhovovalo, jistě pro vás nebude problém kód upravit tak, aby přesun reagoval například jen na pravé tlačítko, neboť identifikace tlačítka je součástí parametrů procedur pro pohyb (či přesněji řečeno události pro stisk a uvolnění tlačítka). Do nich pak stačí vložit na začátek jednoduchou podmínku:

if Button = mbRight then

begin

.

.

.

end;

Do těla této podmínky pak vložíte zbytek kódu události.

Po spuštění naší ukázkové aplikace se vám zobrazí prázdný formulář. Stačí kliknout kamkoliv na jeho plochu a na tomto místě se vytvoří Label s jednoduchým textem, obsahující informace u původních souřadnicích textu (tedy před tím, než s ním začnete hýbat).

Jak vidíte, kód je uveden opět jako celá jednotka, takže stačí, když si vytvoříte nový projekt a celý tento kód umístíte do vytvořené jednotky. Pak již zbývá jen přiřadit událost OnClick formuláře a vše je hotovo.

Zkuste s kódem trošku experimentovat a uvidíte, že se dá tohoto jednoduchého postupu využít k různým účelům. Přesunovat takto můžete i jiné komponenty, třeba tlačítka, ale to již ponechám na vaší fantazii.