在透明表格上绘制矩形非常慢

Question

AlphaBlend和DoubleBuffered设置为True。我有Duo Core 2Ghz和绘图需要100％的CPU，即使我曾经有过BSOD。我的目标是在屏幕上选择自定义区域并获取坐标。启用/取消Windows Aero不会加速。感谢帮助。

unit ZaznaczenieObszaru;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls;

type
  TForm3 = class(TForm)
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
  private
  public
    { Public declarations }
  end;

var
  Form3: TForm3;
  rysuj: boolean;
  poczatekX, poczatekY, xGlobalne, yGlobalne: Integer;
  kolorIzy: TColor;

implementation

{$R *.dfm}

procedure TForm3.FormCreate(Sender: TObject);

begin
  Width := Screen.Width;
  Height := Screen.Height;
  rysuj := False;
  kolorIzy := 14413224;
end;

procedure TForm3.FormKeyPress(Sender: TObject; var Key: Char);
begin
  if (Key = #13) then Close;
end;

procedure TForm3.Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  Image1.Picture.Bitmap := nil;
  Image1.Canvas.Brush.Color := kolorIzy;
  poczatekX := X;
  poczatekY := Y;
  rysuj := true;
end;

procedure TForm3.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if rysuj = true then
  begin
    xGlobalne := X;
    yGlobalne := Y;
    Image1.Picture.Bitmap := nil;
    Image1.Canvas.Brush.Color := kolorIzy;
    Image1.Canvas.Rectangle(poczatekX, poczatekY, xGlobalne, yGlobalne)
  end;
end;

procedure TForm3.Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  rysuj := False;
end;

end.

Answer 1

您可以使用TPaintBox代替TImage（它的Canvas不适用于@Ken已经评论过的用法）并在TPaintBox.OnPaint事件上绘制矩形。不要使用鼠标事件，而是使用TPaintBox.Invalidate。这是一个例子：

procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  poczatekX := X;
  poczatekY := Y;
  rysuj := True;
end;

procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if rysuj then
  begin
    xGlobalne := X;
    yGlobalne := Y;
    PaintBox1.Invalidate;
  end;
end;

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

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  if rysuj then
  begin
    PaintBox1.Canvas.Brush.Color := kolorIzy;
    PaintBox1.Canvas.Rectangle(poczatekX, poczatekY, xGlobalne, yGlobalne);
  end;
end;

我想同样可以仅使用TForm本身而不使用任何图形控件，直接绘制到Form的画布（与TPaintBox相同的事件）。

Answer 2

尝试我的NLDXPSelection组件，这是一个非可视组件，可在任何控件，表单或屏幕上提供绘制蓝色Alpha混合选择。它具有属性OnResize和OnFinish，用于指示选择协作。

可以找到来源here（开源）。