Как перекрасить холст как раз вовремя?

Question

Проблема в том, что я рисую какой-то прямоугольник на рабочем столе, в то время как мышь движется (размер прямоугольника увеличивается), у меня нет лагов, артефактов и т. Д. Все хорошо:

Но когда я изменяю размер прямоугольника, чтобы он был меньше, чем у меня, у меня появляется артефакт:

Красный прямоугольник - это настоящий прямоугольник, все остальное - ошибка.

Идеальное решение - перерисовать холст, но я не могу делать это все время, пока мышь движется.

Есть ли решение сделать что-нибудь, когда мышь полностью останавливается после перемещения?

Обновить

Код:

    unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls;

type
  TForm2 = class(TForm)
    Timer1: TTimer;
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    isDown: Boolean;
    downX, downY: Integer;
  public
    { Public declarations }
    Bild: TBitMap;
  end;

implementation

{Форма реквизита: BorderStyle= bsNone AlphaBlend true, 150 Transparentcolor = true, clBlack }

{$R *.dfm}

procedure TForm2.FormCreate(Sender: TObject);
begin
  Bild := TBitMap.Create;
end;

procedure TForm2.FormDestroy(Sender: TObject);
begin
  Bild.Free;
end;

procedure TForm2.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  isDown := true;
  downX := X;
  downY := Y;
end;

procedure TForm2.FormMouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
const
  cVal = 4;
begin
  if isDown then
  begin
    Self.Canvas.Lock;
    Self.Repaint;
    Self.Canvas.Pen.Color := clNone;
    Self.Canvas.Pen.Width := 1;

    Self.Canvas.Pen.Style := psDot;
    //Self.Canvas.Pen.Mode := pmNotCopy;
    Self.Canvas.Brush.Color := clGreen;
    Self.Canvas.Rectangle(downX, downY, X, Y);
    Self.Canvas.Pen.Style := psSolid;
    Self.Canvas.Brush.Color := clNone;
    Self.Canvas.Unlock;
    { Self.Canvas.Rectangle(downX - cVal, downY - cVal, downX + cVal, downY + cVal);
     Self.Canvas.Rectangle(X - cVal, Y - cVal, X + cVal, Y + cVal);
     Self.Canvas.Rectangle(X - cVal, downY - cVal, X + cVal, downY + cVal);
     Self.Canvas.Rectangle(downX - cVal, Y - cVal, downX + cVal, Y + cVal);

     Self.Canvas.Rectangle(downX - cVal, (downY + Y) div 2 - cVal, downX + cVal,
       (downY + Y) div 2 + cVal);
     Self.Canvas.Rectangle(X - cVal, (downY + Y) div 2 - cVal, X + cVal,
       (downY + Y) div 2 + cVal);

     Self.Canvas.Rectangle((downX + X) div 2 - cVal, downY - cVal,
       (downX + X) div 2 + cVal, downY + cVal);
     Self.Canvas.Rectangle((downX + X) div 2 - cVal, Y - cVal, (downX + X) div 2 + cVal,
       Y + cVal);   }
  end;
end;

function CaptureRect(aRect: TRect; out aBmp: TBitmap): Boolean;
var
  ScreenDC: HDC;
begin
  Result := False;
  try
    with aBmp, aRect do
    begin
      Width := Right - Left;
      Height := Bottom - Top;
      ScreenDC := GetDC(0);
      try
        BitBlt(Canvas.Handle, 0, 0, Width, Height, ScreenDC, Left, Top, SRCCOPY);
      finally
        ReleaseDC(0, ScreenDC);
      end;
    end;
  except
  end;
end;

procedure TForm2.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  r: TRect;
begin
  isDown := false;
  r.Left := downX;
  r.Top := downY;
  r.Right := X;
  r.Bottom := Y;
  CaptureRect(r, Bild);
  Self.Close;
end;

end.

Answer 1

Ваша проблема в том, что вы рисуете не в том месте. Хватит рисовать в OnMouseMove обработчик события. Переместите код рисования в обработчик краски. Например, форма OnPaint обработчик.

Затем в OnMouseMove обработчик событий, да и вообще OnMouseDown а также OnMouseUp, вызов Invalidate на форме, или Win32 InvalidateRect функция, чтобы заставить цикл рисования.

Answer 2

Нарисуйте в многослойном окне вместо этого. Это даст вам большую скорость без артефактов, а Windows позаботится о рисовании.

Многоуровневое окно - это окно, которое создается путем указания WS_EX_LAYERED при создании окна с помощью функции CreateWindowEx. Позже вы можете использовать UpdateLayeredWindow, чтобы установить содержимое этого окна. Таким образом, вы можете рисовать поверх холста без изменения содержимого холста.

Конечно, это более продвинутый подход к решению вашей проблемы. Таким образом, вы должны иметь некоторые знания о Windows API.