Рисуем поверх 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

Удачи.