Показать сообщение отдельно
  #1  
Старый 17.06.2009, 14:24
Аватар для Ayas
Ayas Ayas вне форума
Прохожий
 
Регистрация: 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;

этот код работает, но не так как надо, перемещение объекта происходит только при резком перемещении мыши, парюсь уже двое суток и ничто не могу придумать, гугл ничего существенного не находит, если кто сталкивался с такой проблемой или знает решение - помогите плиз!

заранее благодарен!
Ответить с цитированием