Мерцание при рисовании над компонентами в позиции мыши
Я пытаюсь нарисовать вертикальную линию в позиции X курсора, которая будет двигаться с помощью мыши. Эта линия должна быть нарисована поверх всех компонентов в моей форме. Чтобы добиться этого, я использую фрагмент кода, представленный здесь: /questions/35263433/narisujte-elementyi-upravleniya-v-forme-delphi/35263441#35263441.
Вот код полной формы:
unit UDemo;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, AdvSmoothTimeLine, ImgList, StdCtrls, ComCtrls, ExtCtrls,
System.ImageList, Vcl.AppEvnts;
type
TForm235 = class(TForm)
ImageList1: TImageList;
Panel1: TPanel;
DateTimePicker1: TDateTimePicker;
Edit1: TEdit;
Button1: TButton;
ComboBox1: TComboBox;
ApplicationEvents1: TApplicationEvents;
Button2: TButton;
Panel2: TPanel;
Panel3: TPanel;
Panel4: TPanel;
Panel5: TPanel;
Panel6: TPanel;
Panel7: TPanel;
Panel8: TPanel;
Panel9: TPanel;
Panel10: TPanel;
Panel11: TPanel;
Panel12: TPanel;
procedure FormCreate(Sender: TObject);
procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
FSelecting : Boolean;
FSelectRect : TRect;
FFixedLineX : Integer;
FDragLineX : Integer;
FMousePt, FOldPt: TPoint;
procedure WM_PAINT(var Msg: TWmPaint); message WM_PAINT;
public
{ Public declarations }
end;
var
Form235: TForm235;
implementation
{$R *.dfm}
procedure TForm235.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
var
R: TRect;
Pt: TPoint;
begin
if Msg.message = WM_MOUSEMOVE then begin
// assume no drawing (will test later against the point).
// also, below RedrawWindow will cause an immediate WM_PAINT, this will
// provide a hint to the paint handler to not to draw anything yet.
FMousePt := Point(-1, -1);
// first, if there's already a previous rectangle, invalidate it to clear
if (FOldPt.X > 0) and (FOldPt.Y > 0) then begin
R := Rect(FOldPt.X -1, 0, FOldPt.X + 1, self.Height);
InvalidateRect(Handle, @R, True);
// invalidate childs
// the pointer could be on one window yet parts of the rectangle could be
// on a child or/and a parent, better let Windows handle it all
RedrawWindow(Handle, @R, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_ALLCHILDREN);
end;
// is the message window our form?
if Msg.hwnd = Handle then
// then save the bottom-right coordinates
FMousePt := SmallPointToPoint(TSmallPoint(Msg.lParam))
else begin
// is the message window one of our child windows?
if GetAncestor(Msg.hwnd, GA_ROOT) = Handle then begin
// then convert to form's client coordinates
Pt := SmallPointToPoint(TSmallPoint(Msg.lParam));
windows.ClientToScreen(Msg.hwnd, Pt);
FMousePt := ScreenToClient(Pt);
end;
end;
// will we draw? (test against the point)
if PtInRect(ClientRect, FMousePt) then begin
R := Rect(FMousePt.X - 1, 0, FMousePt.X +1, self.Height);
InvalidateRect(Handle, @R, False);
end;
end;
end;
procedure TForm235.WM_PAINT(var Msg: TWmPaint);
var
DC: HDC;
Rgn: HRGN;
begin
inherited;
if (FMousePt.X > 0) and (FMousePt.Y > 0) then begin
// save where we draw, we'll need to erase before we draw an other one
FOldPt := FMousePt;
// get a dc that could draw on child windows
DC := GetDCEx(Handle, 0, DCX_PARENTCLIP);
// don't draw on borders & caption
Rgn := CreateRectRgn(ClientRect.Left, ClientRect.Top,
ClientRect.Right, ClientRect.Bottom);
SelectClipRgn(DC, Rgn);
DeleteObject(Rgn);
// draw a red rectangle
SelectObject(DC, GetStockObject(DC_BRUSH));
SetDCBrushColor(DC, ColorToRGB(clBlack));
FillRect(DC, Rect(FMousePt.X - 1, 0, FMousePt.X +1, self.Height ), 0);
ReleaseDC(Handle, DC);
end;
end;
procedure TForm235.FormCreate(Sender: TObject);
begin
FSelectRect := TRect.Create(TPoint.Create(self.Left, self.Top));
end;
procedure TForm235.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
FSelectRect.Bottom := self.Height;
FSelectRect.Right := X;
FDragLineX := X;
self.Repaint;
end;
end.
Это работает, как я хотел, за исключением одной вещи. Линия мерцает от постоянного рисования и отрисовки с экрана при перемещении мыши влево и вправо (и, таким образом, при изменении положения X). При перемещении относительно быстро вы также можете заметить, что линия "отстает" от курсора.
У кого-нибудь есть идеи как улучшить этот визуальный эффект? Другая техника / алгоритм? Выделенный компонент где-нибудь?
1 ответ
Рисование имеет низкий приоритет, WM_PAINT отправляется только после очистки очереди сообщений. Входящие сообщения, хотя и размещены, имеют более высокий приоритет. Следовательно, отставание, как вы наблюдаете, является нормальным поведением.
Если вы хотите избежать этого, вы должны отказаться от признания недействительным и вместо этого рисовать то, что вы хотите, когда вы этого хотите. Конечно, стирание также будет вашей обязанностью. Для этого одним из способов было бы сделать снимок без какого-либо рисунка, а затем вставить его, когда вы хотите стереть. С кнопками и аналогичными элементами управления в форме, которые могут изменить их внешний вид, это окажется почти невозможным. Другой способ может заключаться в том, чтобы отслеживать области дочерних элементов, больших дочерних элементов управления, где будет удалена линия, а затем заставить их рисовать себя, не дожидаясь цикла рисования. Я ожидаю, что это будет довольно сложно. Кроме того, пострадает вся производительность вашего приложения. Вы, вероятно, позже спросите: "Почему мой указатель мыши заикается?".
Протестируйте с помощью приведенной ниже версии. Вместо того, чтобы лишать законной силы прямоугольник, когда мышь перемещается, он непосредственно рисует прямоугольник. Подразумевается, что для каждого уведомления о перемещении мыши рисуется линия, а не версия в вопросе, где можно объединить сообщения рисования. Инвалидация дочерних элементов управления все еще остается за системой, и, по-видимому, все еще можно наблюдать поведение задержки, особенно при редактировании элементов управления. Я не знаю какого-либо решения для этого. Кроме того, производительность меньше влияет на мои ожидания.
Одна вещь, которую я заметил, когда пытался скомпилировать ваш тестовый пример, наиболее очевидное препятствие для плавного поведения - это одно добавление себя в код, Repaint вызывать OnMouseMove, Вы должны удалить это, я не знаю, почему вы думали, что вам это нужно.
procedure TForm235.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
var
R: TRect;
Pt: TPoint;
DC: HDC;
Rgn: HRGN;
begin
if Msg.message = WM_MOUSEMOVE then begin
FMousePt := Point(-1, -1);
if (FOldPt.X > 0) and (FOldPt.Y > 0) then begin
R := Rect(FOldPt.X -1, 0, FOldPt.X + 1, self.Height);
InvalidateRect(Handle, @R, True);
RedrawWindow(Handle, @R, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_ALLCHILDREN);
end;
if Msg.hwnd = Handle then
FMousePt := SmallPointToPoint(TSmallPoint(Msg.lParam))
else begin
if GetAncestor(Msg.hwnd, GA_ROOT) = Handle then begin
Pt := SmallPointToPoint(TSmallPoint(Msg.lParam));
winapi.windows.ClientToScreen(Msg.hwnd, Pt);
FMousePt := ScreenToClient(Pt);
end;
end;
if PtInRect(ClientRect, FMousePt) then begin
R := Rect(FMousePt.X - 1, 0, FMousePt.X +1, self.Height);
FOldPt := FMousePt;
DC := GetDCEx(Handle, 0, DCX_PARENTCLIP);
Rgn := CreateRectRgn(ClientRect.Left, ClientRect.Top,
ClientRect.Right, ClientRect.Bottom);
SelectClipRgn(DC, Rgn);
DeleteObject(Rgn);
SelectObject(DC, GetStockObject(DC_BRUSH));
SetDCBrushColor(DC, ColorToRGB(clBlack));
FillRect(DC, Rect(FMousePt.X - 1, 0, FMousePt.X +1, self.Height ), 0);
ReleaseDC(Handle, DC);
end;
end;
end;
procedure TForm235.WMPaint(var Message: TWMPaint);
begin
inherited;
end;