在鼠標位置處繪製組件時閃爍

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;