вторник, 5 марта 2013 г.

Рисуем поверх TWinControl

Это будет шуточная статья, да и задача, рассматривая в ней тоже на практике редко встречается, впрочем в каждой шутке есть только доля шутки.

Когда-то давным давно один уважаемый в Delphi сообществе человек разъяснял - почему есть проблемы с выводом графики поверх контролов.

И объяснял он примерно таким образом:
Вот представим себе стол, пусть он будет аналогом формы (TForm) и мы возьмем фломастер и начнем на нем рисовать. Поверхность стола - это его канва (TCanvas) и на ней у нас полный простор для фантазии. А теперь бросим на стол фотографии. Они представляют из себя TImage и собой они закрыли часть рисунка на столе. Они не убрали то изображение, которое было под ними, они просто находятся поверх него, а само изображение все еще присутствует, хоть его и не видно. Фотографий много, вы их можете перекладывать одну поверх другой, выбирая нравящиеся, тем самым вы неявно работаете со свойствами BringToFront конкретного TImage выводя его на передний план.
Если мы опять захотим нарисовать прямо сейчас - мы возьмем фломастер и сделаем рисунок, и нам не помешают расположенные на столе фотографии, мы просто проведем линию поверх них.
Но вот мы ставим на стол тарелку - она закрывает собой и стол, и фотографии. Это TWinControl. Возьмите фломастер и попробуйте нарисовать линию поверх стола так, чтобы она отобразилась еще и на тарелке, плавно продолжая рисунок с канвы формы  - тогда вы сможете понять как сложно это сделать программно :)




И как-то так зашло, что однажды даже пошел спор, а можно ли это сделать или нет? :)
Ну к примеру у вас есть много элементов управления на форме и нужно через них рисовать линию.
Предлагалось куча вариантов такой реализации, контролы с отсечкой по регионам, оверлей, впрочем решений было много, смелых и разных но ветка угасла.

Сегодня совершенно случайно увидел в одном из сообществ вопрос именно такого плана - как нарисовать поверх и вспомнил про свой давний примерчик, написанный как раз для той старой ветки.

Смысл примера очень прост - если переложить на изначальное объяснение концепции, то зачем рисовать на столе, если рисунок не виден на тарелке? Пусть тарелка рисует на самой себе.

С точки зрения программной реализации суть сводится к перекрытию оконной процедуры, в которой вывод графики производится уже непосредственно на канве контрола.

Выглядит следующим образом:


Ну и сам код:

function ButtonSubclassProc(hWnd: HWND; Msg: Integer;
  wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  OldWndProc, LeftOffset, TopOffset: Integer;
  WndRect, ParentRect, ParentClientRect: TRect;
  TmpCanvas: TCanvas;
  X1, Y1, X2, Y2: Integer;
begin
  OldWndProc := GetWindowLong(hWnd, GWL_USERDATA);
  Result := CallWindowProc(Pointer(OldWndProc), hWnd, Msg, wParam, lParam);
  if Msg = WM_PAINT then
  begin
    GetWindowRect(hWnd, WndRect);
    GetWindowRect(GetParent(hWnd), ParentRect);
    GetClientRect(GetParent(hWnd), ParentClientRect);
    TopOffset := (ParentRect.Bottom - ParentRect.Top) -
      (ParentClientRect.Bottom - ParentClientRect.Top);
    LeftOffset := (ParentRect.Right - ParentRect.Left) -
      (ParentClientRect.Right - ParentClientRect.Left);
    X1 := ParentClientRect.Left + LeftOffset div 2 - (WndRect.Left - ParentRect.Left);
    Y1 := ParentClientRect.Top + TopOffset -
      (WndRect.Top - ParentRect.Top) - LeftOffset div 2;
    X2 := X1 + (ParentClientRect.Right - ParentClientRect.Left);
    Y2 := Y1 + (ParentClientRect.Bottom - ParentClientRect.Top);
    TmpCanvas := TCanvas.Create;
    try
      TmpCanvas.Handle := GetDC(hWnd);
      TmpCanvas.Pen.Color := clRed;
      TmpCanvas.Pen.Width := 4;
      TmpCanvas.MoveTo(X1, Y1);
      TmpCanvas.LineTo(X2, Y2);
    finally
      ReleaseDC(hWnd, TmpCanvas.Handle);
      TmpCanvas.Free;
    end;
  end;
end;

procedure TForm1.ButtonClick(Sender: TObject);
begin
  ReleaseButtons;
  GenerateButtons;
  Invalidate;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := True;
  GenerateButtons;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  ReleaseButtons;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  Canvas.Pen.Color := clRed;
  Canvas.Pen.Width := 4;
  Canvas.MoveTo(0, 0);
  Canvas.LineTo(ClientWidth, ClientHeight);  
end;

procedure TForm1.FormResize(Sender: TObject);
var
  I: Integer;
begin
  for I := 0 to 19 do
    ButtonsData[I].Invalidate;
  Invalidate;
end;

procedure TForm1.GenerateButtons;
var
  I: Integer;
begin
  Randomize;
  for I := 0 to 19 do
  begin
    ButtonsData[I] := TButton.Create(Self);
    ButtonsData[I].Parent := Self;
    ButtonsData[I].Left := Random(ClientWidth - ButtonsData[I].Width);
    ButtonsData[I].Top := Random(ClientHeight - ButtonsData[I].Height);
    ButtonsData[I].Caption := 'Button' + IntToStr(I + 1);
    ButtonsData[I].OnClick := ButtonClick;
    SetWindowLong(ButtonsData[I].Handle,
      GWL_USERDATA, GetWindowLong(ButtonsData[I].Handle, GWL_WNDPROC));
    SetWindowLong(ButtonsData[I].Handle,
      GWL_WNDPROC, Integer(@ButtonSubclassProc));
  end;
end;

procedure TForm1.ReleaseButtons;
var
  I: Integer;
begin
  for I := 0 to 19 do
    ButtonsData[I].Free;
end;

В нем создаются 20 кнопок, у каждой из которых перекрывается оконная процедура посредством SetWindowLong + GWL_WNDPROC. В новой оконной процедуре просто рисуем на канве каждого конкретного элемента.

Попробуйте изменить размеры формы и понаблюдать за поведением линии.

Ну и на этом я заканчиваю.
Моя задача в публикации данного шуточного кода закончена, а у вас возможно появился новый повод для размышлений :)

Исходный код забирайте здесь: http://rouse.drkb.ru/blog/draw_over_controls.zip

Удачи.

18 комментариев:

  1. Анонимный6 марта 2013 г., 7:34

    Отлично, но какая практическая цель применения?

    ОтветитьУдалить
    Ответы
    1. Интерактивный хелп/туториал, например. Там где стрелочками показывается на какую кнопку нажать что бы что-то сделать. Можно много всего придумать :)

      Удалить
    2. Ну да либо туториал, либо таким образом можно писать поперек формы "TRIAL EXPIRED" указывая что пора платить деньгу :)
      А вообще на практике я такого никогда не применял, поэтому и сказал что по сути это шутка :)

      Удалить
    3. Дизайнер форм:
      http://www.youtube.com/watch?v=9MAYR0ygOEY

      Правда я там использовал другой подход: создавал поверх окна дизайнера своё окно (прозрачное и пропускающее сообщения) и рисовал уже на нём. Так и проще, чем распиливать изображение и отрисововать на самих контролах (а на контролах могут и есть другие контролы), и не возникает артефактов при отрисовки на некоторых контролах (полей ввода).

      Удалить
    4. А вообще основная цель - это сама возможность кастомной отрисовки на контролах, которые сами по себе такую возможность не предоставляют.

      Удалить
  2. Понятно, пойду рисовать стрелочки указывающие на кнопки регистрации снимающие триальный период! ;)

    ОтветитьУдалить
  3. К слову, у Антона Григорьева есть статья и один из примеров (PanelMsg) затрагивает данную тему:
    http://www.delphikingdom.com/asp/viewitem.asp?catalogid=169

    ОтветитьУдалить
    Ответы
    1. >> Дизайнер форм:
      >> http://www.youtube.com/watch?v=9MAYR0ygOEY

      С дизайнером форм идея понравилась :)

      Удалить
  4. а как рисовать поверх стороннего приложения, не захватывая окна, ну то есть поверх всего, что есть на рабочем столе?

    ОтветитьУдалить
  5. var
    HDC1:HDC;
    begin


    HDC1:=GetDC(GetDesktopWindow());
    SetPixel(HDC1, 500, 500, RGB(255, 0, 0));
    Rectangle(HDC1,30,40,100,200);

    end;

    о

    ОтветитьУдалить
  6. Через DC, благо GDI хэндлы глобальны. Но лучше посмотреть вот это обсуждение:
    https://plus.google.com/118119558482727549390/posts/M4TxziqxK6o
    Решение от Михаила Демидова гораздо привлекательней, чем мой вариант.
    ЗЫ: Даже не думал что тема будет настолько интересной, если честно :)

    ОтветитьУдалить
    Ответы
    1. Решение от Михаила Демидова очень сильно мерцает при перерисовке. Как можно от этого избавиться (DoubleBuffer не помогает)?

      Удалить
    2. Ну... это вопрос к автору решения :)

      Удалить
  7. Вот такое сделай на VCL :)
    https://www.youtube.com/watch?feature=player_embedded&v=7534l8NdfpU

    ОтветитьУдалить
  8. Саш, дело было не совсем так. Новичок задал вопрос - почему он кладет картинку (TImage) на кнопку (TButton), а она вдруг неожиданно для него все равно оказывается под кнопкой?

    Можно было бы долго рассказывать ему про TGraphicControl и TWinControl, про TCanvas и DС - но что бы он из этого рассказа понял, если как раз этих вещей он и не знает? Вот и пришла мысль провести аналогию с хорошо знакомой ему ситуацией, которую он видел тысячи раз - рисунок на крышке стола и предмет на той же крышке, который всегда будет поверх рисунка. А после того, как в голове у парня уже есть вполне понятная ему картина, можно рассказывать ему про DC, про собственную и родительскую канву, про TGraphicControl и TWinControl.

    А что по дочерним оконным контролам можно вполне спокойно рисовать - разве кто сомневался? Раз есть DC, значит можно. Весь вопрос только в реализации - что ты и сделал, причем не без изящества.

    ОтветитьУдалить
    Ответы
    1. Юр, тонкостей я конечно уже не помню, да и давно это было. Но вот тот спич, который ты выдал при объяснении данного материала мне целиком запомнился (а уж сколько лет прошло - все еще помню :). Это ж мало кто так может подробно и со смыслом вбить в мозг информацию, более гениальный вариант я слышал только здесь: http://www.youtube.com/watch?v=suVHeYEftYg

      Удалить
    2. > http://www.youtube.com/watch?v=suVHeYEftYg

      Да, ЭТО превзойти нельзя.
      :o)

      Удалить