delphi - 在鼠标位置的组件上绘图时闪烁

Question

我试图在光标的 X 位置绘制一条垂直线，该线将随鼠标移动。这条线必须绘制在我的表单上所有组件的“顶部”。为了实现这一点，我使用此处提供的一段代码:https://stackoverflow.com/a/4481835 .

这是完整表单的代码:

    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 位置)时，线条会因不断从屏幕上绘制和取消绘制而闪烁。当移动相对较快时，您还可以注意到线条“落后于”光标。

有人知道如何改善这种视觉效果吗？另一种技术/算法？某处的专用组件？

Answer 1

绘画优先级较低，只有在消息队列清空后才会调度 WM_PAINT。尽管已发布，但输入消息的优先级更高。因此，正如您所观察到的，滞后是正常行为。

如果你想避免这种情况，你应该放弃无效化，而是在你想要的时候画你想要的东西。当然，删除也是你的责任。为此，一种方法是捕获不进行任何绘图的图像，然后在您想要删除时粘贴它。由于表单上的按钮和类似控件可以改变其外观，这几乎是不可能的。另一种方法可能是跟踪要删除线的子控件、孙控件的区域，然后让它们自行绘制而无需等待绘制周期。我预计这会相当复杂。此外，您的所有应用程序的性能都会受到影响。您稍后可能会问，“为什么我的鼠标指针卡顿？”。

---

使用以下版本进行测试。它不会在鼠标移动时使矩形失效，而是直接绘制矩形。这意味着，对于每个鼠标移动通知，都会绘制一条线，这与可以合并绘画消息的问题中的版本相反。子控件的失效仍然由系统负责，值得注意的是，仍然可以观察到滞后行为，尤其是在编辑控件上。我不知道有什么解决办法。除此之外，性能对我的期望的负面影响较小。

当我尝试编译您的测试用例时，我注意到一件事，流畅行为的最明显障碍是在代码中添加您自己，即 OnMouseMove< 中的 Repaint 调用。你必须删除它，我不知道你为什么认为你需要它。

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;