I'm trying to draw a vertical line at the X position of the cursor that would move with the mouse. This line would have to be drawn 'on top' of all components on my form. To achieve this, i'm using a piece of code provided here : https://stackoverflow.com/a/4481835 .
Here is the code of the full form :
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.
It works like I wanted it to except for one thing. The line flickers from constantly being drawn and undrawn from the screen when you move the mouse left and right (and so changing X position). When moving relatively rapidly you can also notice the line 'lagging behind' the cursor.
Does anyone has an idea on how to improve this visual effect? Another technic / algorithm? A dedicated component somewhere?
Painting is low priority, a WM_PAINT is dispatched only after the message queue is emptied. Although posted, input messages are higher priority. Hence lagging as you observe is normal behavior.
If you want to avoid that you should give up invalidating and instead paint what you want when you want it. Of course, then, erasing will be your responsibility too. For that, one way would be to capture an image without any drawing and later paste it when you want to erase. With buttons and similar controls on the form which can change their appearances, that's going to prove near to be impossible. Another way could be to keep track of areas of child, grand child controls where the line is going to be removed, and then have them paint themselves without waiting a paint cycle. I'd expect that to be quite complicated. Additionally, all of your application's performance will suffer. You'll probably later ask, "why does my mouse pointer stutter?".
Test with the below version. Instead of invalidating a rectangle when the mouse is moved, it directly draws a rectangle. The implication is that, for every mouse move notification a line is drawn as opposed to the version in the question where paint messages may be consolidated. Invalidation of the child controls is still left to the system and, noticeably, it is still possible to observe lag behavior, especially on edit controls. I don't know any fix for that. Apart from that, performance is less adversely effected to my expectations.
One thing I noticed when I attempted to compile your test case, the most obvious obstacle for smooth behavior is one addition of yourself to the code, which is the Repaint call in OnMouseMove. You have to remove that, I don't know why do you thought you needed that.
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;