如何在 OnMouseDown 和 OnMouseUp 之间绘制一个选择矩形？

Question

我有代码可以让用户 select 在图像上创建一个矩形，该矩形将成为表单中的孔。但是在我从组合区域创建这个 hole 之前，我想用红色标记这个矩形区域。

所以在这张图中，鼠标拖动的时候应该把小矩形大小的区域画成红色：

到目前为止我的代码是：

private
    { Private declarations }
    Point1, Point2: TPoint;
    function ClientToWindow(const p: TPoint): TPoint;
    procedure AdjustRegions;


function TForm1.ClientToWindow(const p: TPoint): TPoint;
begin
  Result := ClientToScreen(p);
  Result.X := Result.X - Left;
  Result.Y := Result.Y - Top;
end;

procedure TForm1.AdjustRegions;
var
  rForm, rWindow: hrgn;
  headerHeight: Integer;
begin

  if ((Point2.X - Point1.X) <= 0) or ((Point2.Y - Point1.Y) <= 0) then
    SetWindowRgn(Self.Handle, 0, True)
  else
  begin
    rForm := CreateRectRgn(0, 0, Width, Height);
    rWindow := CreateRectRgn(
      ClientToWindow(Point1).X,
      ClientToWindow(Point1).Y,
      ClientToWindow(Point2).X,
      ClientToWindow(Point2).Y);

    CombineRgn(rForm, rForm, rWindow, RGN_DIFF);
    SetWindowRgn(Self.Handle, rForm, True);

  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
FillChar(Point1, SizeOf(Point1), 0);
FillChar(Point2, SizeOf(Point2), 0);
end;

procedure TForm1.FormResize(Sender: TObject);
begin
AdjustRegions;
end;

procedure TForm1.img1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
Point1.X := X;
Point1.Y := Y;
end;

procedure TForm1.img1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
if X > Point1.X then
    Point2.X := X
  else
    begin
      Point2.X := Point1.X;
      Point1.X := X;
    end;
  if Y > Point1.Y then
    Point2.Y := Y
  else
    begin
      Point2.Y := Point1.Y;
      Point1.Y := Y;
    end;

  AdjustRegions;
end;

欢迎提出任何建议。

Answer 1

您可以在 OnMouseMove 事件中更新 canvas。

这可能看起来像：

unit Unit1;

interface

uses
  Winapi.Windows, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms,
  Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    procedure FormResize(Sender: TObject);
    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure PaintBox1Paint(Sender: TObject);
  private
    FSelecting: Boolean;
    FSelection: TRect;
    procedure AdjustFormRegion;
    function ClientToWindow(const P: TPoint): TPoint;
  end;

implementation

{$R *.dfm}

procedure TForm1.AdjustFormRegion;
var
  FormRegion: HRGN;
  HoleRegion: HRGN;
begin
  FSelection.NormalizeRect;
  if FSelection.IsEmpty then
    SetWindowRgn(Handle, 0, True)
  else
  begin
    FormRegion := CreateRectRgn(0, 0, Width, Height);
    HoleRegion := CreateRectRgn(
      ClientToWindow(FSelection.TopLeft).X,
      ClientToWindow(FSelection.TopLeft).Y,
      ClientToWindow(FSelection.BottomRight).X,
      ClientToWindow(FSelection.BottomRight).Y);
    CombineRgn(FormRegion, FormRegion, HoleRegion, RGN_DIFF);
    SetWindowRgn(Handle, FormRegion, True);
  end;
end;

function TForm1.ClientToWindow(const P: TPoint): TPoint;
begin
  Result := PaintBox1.ClientToScreen(P);
  Dec(Result.X, Left);
  Dec(Result.Y, Top);
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  AdjustFormRegion;
end;

procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FSelection.Left := X;
  FSelection.Top := Y;
  FSelecting := True;
end;

procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if FSelecting then
  begin
    FSelection.Right := X;
    FSelection.Bottom := Y;
    PaintBox1.Invalidate;
  end;
end;

procedure TForm1.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FSelecting := False;
  FSelection.Right := X;
  FSelection.Bottom := Y;
  PaintBox1.Invalidate;
  AdjustFormRegion;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  PaintBox1.Canvas.Brush.Color := clRed;
  PaintBox1.Canvas.Rectangle(FSelection);
end;

end.

一些一般性的评论：

您不必将 TPoint 初始化为零，这将自动完成。见 the documentation:

Because a constructor always clears the storage it allocates for a new object, all fields start with a value of zero (ordinal types), nil (pointer and class types), empty (string types), or Unassigned (variants). Hence there is no need to initialize fields in a constructor's implementation except to nonzero or nonempty values.
虽然Image组件可以用于自定义绘图，但它是为显示图片而设计的。我建议您将其更改为 PaintBox（或 Form 本身）。
由于您使用 Delphi XE5，请使用其 TRect 成员，例如 NormalizeRect、IsEmpty 等...

如何在 OnMouseDown 和 OnMouseUp 之间绘制一个选择矩形？

How to draw a selection rectangle between OnMouseDown and OnMouseUp?

delphi

rectangles

delphi-xe5