Shapeのサイズ変更 (ID：33341)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

type

TDownLocation = (dlLeft,dlTop,dlRight,dlBottom);
  TDownLocations = set of TDownLocation;

const

SIZE = 10;

var

FMouseDown: Boolean;
  FMouseX,FMouseY,FMouseZ: Integer;
  DownLocations : TDownLocations;

implementation

{$R *.dfm}

procedure TForm2.Shape1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
    if (X < SIZE) or (Y < SIZE) or (X > Shape1.Width - SIZE - 1 ) or (Y > Shape1.Height - SIZE - 1 ) then
    begin
      FMouseDown := True;
      FMouseX := X;
      FMouseY := Y;
      DownLocations := [];
      if (X < SIZE) then DownLocations := DownLocations + [dlLeft];
      if (Y < SIZE) then DownLocations := DownLocations + [dlTop];
      if (X > Shape1.Width - SIZE -1) then DownLocations := DownLocations + [dlRight];
      if (Y > Shape1.Height - SIZE -1) then DownLocations := DownLocations + [dlBottom];
    end;
end;

procedure TForm2.Shape1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin

if (X < SIZE) then
    begin
      if (Y < SIZE) then
      begin
        Shape1.Cursor := crSizeNWSE;
      end
      else
      if (Y > Shape1.Height - SIZE -1) then
      begin
        Shape1.Cursor := crSizeNESW;
      end
      else
      begin
        Shape1.Cursor := crSizeWE;
      end;
    end
    else
    if (X > Shape1.Width - SIZE -1) then
    begin
      if (Y < SIZE) then
      begin
        Shape1.Cursor := crSizeNESW;
      end
      else
      if (Y > Shape1.Height - SIZE -1) then
      begin
        Shape1.Cursor := crSizeNWSE;
      end
      else
      begin
        Shape1.Cursor := crSizeWE;
      end;
    end
    else
    if (Y < SIZE) then
    begin
      Shape1.Cursor := crSizeNS;
    end
    else
    if (Y > Shape1.Height - SIZE -1) then
    begin
      Shape1.Cursor := crSizeNS;
    end
    else
    begin
      Shape1.Cursor := crDefault;
    end;

if FMouseDown = True then
    begin

//左(増)
      if ( X < SIZE) and (X < FMouseX) and (dlLeft in DownLocations) then
      begin
        Shape1.Left := Shape1.Left - (FMouseX - X);
        Shape1.Width := Shape1.Width + (FMouseX - X);

end;

//左(減)
      if (X > SIZE) and (X > FMouseX) and (dlLeft in DownLocations) then
      begin
        Shape1.Left := Shape1.Left + (X - FMouseX);
        Shape1.Width := Shape1.Width - (X - FMouseX);
      end;

//上(増)
      if (Y < SIZE) and (Y < FMouseY) and (dlTop in DownLocations) then
      begin
        Shape1.Top := Shape1.Top - (FMouseY - Y);
        Shape1.Height := Shape1.Height + (FMouseY - Y);
      end;

//上(減)
      if (Y > SIZE) and (Y > FMouseY) and (dlTop in DownLocations) then
      begin
        Shape1.Top := Shape1.Top + (Y - FMouseY);
        Shape1.Height := Shape1.Height - (Y - FMouseY);
      end;

//右(減)
      if ( X < Shape1.Width -SIZE -1) and (X < FMouseX) and (dlRight in DownLocations) then
      begin
        Shape1.Width := Shape1.Width - (FMouseX - X);
        FMouseX := X;
      end;

//右(増)
      if (X > Shape1.Width - SIZE -1) and (X > FMouseX) and (dlRight in DownLocations) then
      begin
        Shape1.Width := Shape1.Width + (X - FMouseX);
        FMouseX := X;
      end;

//下(減)
      if ( Y < Shape1.Height -SIZE -1) and (Y < FMouseY) and (dlBottom in DownLocations) then
      begin
        Shape1.Height := Shape1.Height - (FMouseY - Y);
        FMouseY := Y;
      end;

//下(増)
      if (Y > Shape1.Height - SIZE -1) and (Y > FMouseY) and (dlBottom in DownLocations) then
      begin
        Shape1.Height := Shape1.Height + (Y - FMouseY);
        FMouseY := Y;
      end;

end;
end;

procedure TForm2.Shape1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
    FMouseDown := False;
end;

反転させたら反応しなくなる

←解決時は質問者本人がここをチェックしてください。

戻る