delphi - 在透明表单上绘制矩形非常慢

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本身没有任何图形控件，通过直接绘制到表单的 Canvas (与 TPaintBox 相同的事件)。