
17.06.2009, 14:24
|
 |
Прохожий
|
|
Регистрация: 17.06.2009
Сообщения: 3
Репутация: 10
|
|
Snap to Grid (перемещение объекта по сетке)
всем привет!
помогите пожалуйста реализовать код перемещения визуального объекта на форме по сетке
Код:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TMouseAction = (maNone, maMove, maResize);
TForm1 = class(TForm)
procedure FormPaint(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormCreate(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
FMouseAction: TMouseAction;
FGridX, FGridY: Integer;
FSnapToGrid: Boolean;
FMoveStart: TPoint;
FComponent: record
X, Y, Width, Height: Integer;
end;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
DoubleBuffered := True;
with FComponent do
begin
X := 23;
Y := 47;
Width := 278;
Height := 138;
end;
FMouseAction := maNone;
FGridX := 10;
FGridY := 10;
FSnapToGrid := True;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FMoveStart := Point(X, Y);
if (X >= FComponent.X) and (X <= FComponent.X + FComponent.Width) and
(Y >= FComponent.Y) and (Y <= FComponent.Y + FComponent.Height) then
FMouseAction := maMove;
FormPaint(Sender);
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
MX, MY, GX, GY: Integer;
begin
if FMouseAction = maMove then
begin
MX := FComponent.X - FMoveStart.X + X;
MY := FComponent.Y - FMoveStart.Y + Y;
if FSnapToGrid then
begin
// перемещение по сетке
GX := Round(MX / FGridX) * FGridX;
GY := Round(MY / FGridY) * FGridY;
if Abs(FComponent.X - MX) >= FGridX then
FComponent.X := GX;
if Abs(FComponent.Y - MY) >= FGridY then
FComponent.Y := GY;
end
else
begin
FComponent.X := MX;
FComponent.Y := MY;
end;
end;
FMoveStart := Point(X, Y);
Repaint;
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FMouseAction := maNone;
end;
procedure TForm1.FormPaint(Sender: TObject);
var I, J: Integer;
begin
I := 0;
while I < Height do
begin
J := 0;
while J < Width do
begin
Canvas.Pixels[J, I] := clBlack;
Inc(J, FGridX);
end;
Inc(I, FGridY);
end;
Canvas.Rectangle(FComponent.X, FComponent.Y,
FComponent.X + FComponent.Width,
FComponent.Y + FComponent.Height);
end;
end.
проблема здесь:
Код:
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
MX, MY, GX, GY: Integer;
begin
if FMouseAction = maMove then
begin
MX := FComponent.X - FMoveStart.X + X;
MY := FComponent.Y - FMoveStart.Y + Y;
if FSnapToGrid then
begin
// перемещение по сетке
GX := Round(MX / FGridX) * FGridX;
GY := Round(MY / FGridY) * FGridY;
if Abs(FComponent.X - MX) >= FGridX then
FComponent.X := GX;
if Abs(FComponent.Y - MY) >= FGridY then
FComponent.Y := GY;
end
else
begin
FComponent.X := MX;
FComponent.Y := MY;
end;
end;
FMoveStart := Point(X, Y);
Repaint;
end;
этот код работает, но не так как надо, перемещение объекта происходит только при резком перемещении мыши, парюсь уже двое суток и ничто не могу придумать, гугл ничего существенного не находит, если кто сталкивался с такой проблемой или знает решение - помогите плиз!
заранее благодарен!
|