Мерцание при рисовании компонентов в положении мыши

Я пытаюсь нарисовать вертикальную линию в позиции 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). При относительно быстром перемещении вы также можете заметить, что линия «отстает» от курсора.

Кто-нибудь знает, как улучшить этот визуальный эффект? Другая техника/алгоритм? Выделенный компонент где-то?


person mathieu    schedule 25.10.2016    source источник
comment
Какова цель этого линейного рисунка? Почему у вас есть TRect в вашем коде?   -  person Tom Brunberg    schedule 25.10.2016
comment
@Tom, прямоугольник используется в разных местах для аннулирования и рисования прямоугольной области. Что именно вы спрашиваете?   -  person Sertac Akyuz    schedule 26.10.2016
comment
@Sertac, хорошо, прямо. Я спрашиваю, какова цель рисования всей линии, потому что есть несколько решений, но они открыты, если, например, линия должна быть постоянной.   -  person Tom Brunberg    schedule 26.10.2016
comment
@ Том, хорошо. Конечно, я не знаю, почему существует бегущая линия. Если бы мне пришлось угадывать, я бы подумал, что это проекция положения мыши на какую-то ось, но кто знает...   -  person Sertac Akyuz    schedule 26.10.2016
comment
Почему вы вообще сами рисуете линию, а потом сами выясняете, какие элементы управления нужно обновить. Не было бы проще просто создать два новых компонента, которые будут представлять ваши линии, а затем изменить их положение в соответствии с движением мыши и позволить окнам выполнять всю перерисовку, когда это необходимо. Все, что вам нужно позаботиться, это то, чтобы эти компоненты не обрабатывали никакие сообщения мыши или клавиатуры, но позволяли другим окнам вашей программы обрабатывать их.   -  person SilverWarior    schedule 26.10.2016
comment
Хорошо, может быть, здесь нужно больше объяснений того, чего я пытаюсь достичь. Что я хочу сделать, так это интерактивный способ выбора раздела формы путем перетаскивания. Таким образом, в основном линия следует за курсором, затем пользователь нажимает левую кнопку мыши (мышь вниз) и перетаскивает вправо (или влево) в другую позицию X. Вертикальная линия сохраняется в первой позиции X, а вторая начинает следовать за курсором до второй точки (где левая кнопка мыши отпущена — мышь вверх). Это будет использоваться для выбора части временной шкалы для увеличения.   -  person mathieu    schedule 26.10.2016


Ответы (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;
person Sertac Akyuz    schedule 25.10.2016
comment
Большое спасибо за ваше время и объяснения. Так что, если я буду следовать правильно, нет гладкого способа добиться того, что я делаю - иметь вертикальную линию, следующую за курсором и находящуюся над некоторыми уже нарисованными компонентами. - person mathieu; 26.10.2016
comment
@tab - Пожалуйста. Производительность приложения/системы будет снижена, однако это может не означать, что *гладкого пути не существует, машина все еще может справляться с плавным движением в зависимости от других факторов. Учитывая, зачем вам это нужно, относительно вашего комментария Сильверу по вопросу, совершенно не нужно, если вы спросите меня. - person Sertac Akyuz; 26.10.2016