Не являюсь поклонником запихнуть что-нибудь в заголовок, но аргумент «жаль столько места пропадает» принимаю и поддерживаю. Поэтому продолжим размещать элементы редактирования в заголовке. Сейчас будем размещать Edit и ему подобных. Легально, без фокусов.
Что не так с предыдущим методом? К сожалению, размещая Edit подобным образом, мы теряем курсор внутри объекта. А без него выглядит и неуютно, и топорно. И самое главное, при таком методе мы теряем AeroSnap.
Описание проблемы
Как известно, Windows не позволяет размещать свои объекты в не-клиентской области окна. По крайней мере, нет такого API, которое позволило бы это сделать. Рисовать в заголовке можно без проблем, а назначить окну родителя с указанием разместиться в не-клиентской области нельзя. Все попытки взять заголовок под контроль оборачиваются в конечном счёте неким фокусом. В подавляющем большинстве случаев, это панель, которая притворяется заголовком.
В Delphi, начиная с 10.4, это фокус узаконили тем, что предоставили новый компонент TTitleBarPanel. Что вызвало ожидаемую радость: «TTitleBarPanel – это очередной пример простоты и элегантности разработки приложений с использованием Delphi». К 12-й версии он всё также плох.
К основным недостаткам TitleBarPanel можно отнести то, что он не дружит со стилями, не знает про тёмную тему, Label’ы и ряд других отображает хуже некуда. Ну и так далее, пишите в комментариях, что можно ещё предъявить.
Цели и направления
Конечно, хотелось бы, чтобы подобная фишка работала на всех ОС, но ограничимся 10, 11. Для реализации задуманного будем использовать DWM, а в Window 7 он весьма так себе. Чтобы работало на всех осях, просто делаем панель вместо заголовка и гордо уходим в закат.
Хочется размещать компоненты максимально легально, без фокусов. Системные кнопки в заголовке должны остаться родными. Windows очень плохо реагирует на подмену и пытается рисовать их всегда. От этого происходят разные неприятности, когда под своей кнопкой закрытия окна мелькает виндусовая. Возникает ощущение от интерфейса, как от баннера на старом доме.
Дельфовый TitleBarPanel системные кнопки полностью подменяет, рисует свои. Я не против хаков и фокусов, но window-заголовок меняется от версии к версии, и хочется, чтобы было меньше проблем и сейчас, и в будущем. Если делаем свой заголовок, то либо делаем нехилый определитель текущих системных цветов, либо на всё забиваем и всю палитру делаем свою. Если нам надо разместить в заголовке всего лишь пару контролов, то вся эта овчинка выделки не стоит.
Совершенно не хочется рисовать самостоятельно не-клиентскую область окна, обрабатывать WM_NCPAINT, ловить артефакты. Хочется максимально задействовать возможности Delphi и поменьше писать руками. Всё равно придётся, но давайте на это раз поменьше!
Очень хочется адекватного поведения при тёмной теме. Про тёмную тему будем говорить в следующей статье.
Пишем в XE 7, потом проверим в 12-ой Delphi. Так случилось, что XE 7 очень популярна, и люди неохотно переходят с неё на новые версии. Ситуация, как с Delphi 7 в своё время. Поддерживать исходники для Delphi 7 уже перестал, но XE 7 пока актуальна.
Начинаем
Предположим, у меня есть такая линейка компонент на форме и я хочу переместить их в заголовок. В наличии: TButtonEdit, наследник TCustomEdit, TComboBox и TButton. TButtonEdit взят, чтобы посмотреть, как будет отрисовываться правая кнопка. Обычно в заголовок уходит что-то, связанное либо с поиском, либо фильтром, а эта история всегда с кнопкой. TButton выбран по той причине, что обычно плохо отображается в не-клиентской области. Как работать с DWM и как определять его наличие, описал в этой статье. Сейчас постараемся поменьше обращаться к DwmApi и максимально использовать всё то хорошее, что есть в Delphi.
Заголовок в клиентской области
Если нельзя разместить TEdit в не-клиентской области, то пусть не-клиентская область станет частично клиентской. Этим занимается функция DwmExtendFrameIntoClientArea. Она расширяет рамку окна в клиентскую область. Её надо вызывать всякий раз при наступлении определённых событий, читаем подобности по ссылке выше.
В Delphi за работу с DwmExtendFrameIntoClientArea отвечает базовый класс формы TCustomForm. Если у формы включён GlassFrame, то dwm-рамка окна корректно отработает, и нам не придётся ничего учитывать.
Оформим всю работу, связанную с получением информации и работе с заголовком, в отдельный класс TFormTitleInfo. Мало ли, понадобится ещё где-нибудь.
Если мы хотим, чтобы область заголовка «залезла» в клиентскую часть окна, необходимо установить значение отступа сверху (по сути, высоту заголовка) в свойство формы GlassFrame.Top и включить GlassFrame.Enabled.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
class procedure TFormTitleInfo.UpdateGlassFrame(AForm: TCustomForm; out ARect: TRect); begin ARect := TRect.Empty; if AForm = nil then exit; AForm.HandleNeeded; if not AForm.HandleAllocated then exit; ARect := GetAdjustWindowRect(AForm.Handle); AForm.GlassFrame.Top := -ARect.Top AForm.GlassFrame.Enabled := True; SetWindowPos(AForm.Handle, 0, AForm.Left, AForm.Top, AForm.Width, AForm.Height, SWP_FRAMECHANGED or SWP_NOACTIVATE); end; |
Про текущую высоту заголовка спросим Windows. Функция GetAdjustWindowRect запрашивает прямоугольник отступов окна. Внутри использует AdjustWindowRectEx, которая вычисляет прямоугольник, полностью охватывающий клиентскую область. Если мы скормим ей нулевой прямоугольник, то получим значения отступов, включая и размер заголовка. Эта функция API не поддерживает DPI и не должна использоваться, если вызывающий поток поддерживает DPI. В этом случае необходимо использовать AdjustWindowsRectExForDPI.
В XE 7 нет поддержки высокого разрешения. Начиная с 10.4, в Delphi появилась функция AdjustWindowRectExForWindow (Vcl.Controls), которая учитывает сказанное выше про DPI. Поэтому и мы будем учитывать версию компилятора:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
class function TFormTitleInfo.GetAdjustWindowRect(AHandle: HWND): TRect; var dwStyle, dwExStyle: DWORD; begin Result := TRect.Empty; dwStyle := GetWindowLong(AHandle, GWL_STYLE); dwExStyle := GetWindowLong(AHandle, GWL_EXSTYLE); {$IF CompilerVersion < 34} AdjustWindowRectEx(Result, dwStyle, False, dwExStyle); {$ELSE} // Версия Delphi 10.4 и выше // Местонахождение: Vcl.Controls AdjustWindowRectExForWindow(Result, dwStyle, False, dwExStyle, AHandle); {$ENDIF} end; |
Наблюдаем такое:
Область заголовка расширилась, компоненты на месте, кнопка ожидаемо глючит, иконки в ButtonEdit не видно. Всё круто!
Убираем лишний заголовок
Следующим шагом уберём верхнюю часть заголовка. Необходимо убрать не-клиентскую область сверху. Для этого нам понадобится обработать событие WM_NCCALCSIZE. Мероприятия, с этим связанные, описал в предыдущей статье. Внимание: в случае, когда действительно ограничиваем, inherited не вызываем.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
procedure TFmMain.WMNCCalcSize(var Message: TWMNCCalcSize); var M: TMonitor; rct: TRect; Params: PNCCalcSizeParams; begin if (FTitleInfo<>nil) and (WindowState <> wsMinimized) and Message.CalcValidRects then begin Params := Message.CalcSize_Params; Inc(Params.rgrc[0].Left, FTitleInfo.FrameRect.Right); Dec(Params.rgrc[0].Right, FTitleInfo.FrameRect.Right); Dec(Params.rgrc[0].Bottom, FTitleInfo.FrameRect.Right); if WindowState = wsMaximized then begin M := Monitor; if (M = Screen.PrimaryMonitor) and (M.WorkareaRect = M.BoundsRect) then begin rct := TFormTitleInfo.GetTaskBarBounds; if not rct.IsEmpty then if rct.Width > rct.Height then Dec(Params.rgrc[0].Bottom) else Dec(Params.rgrc[0].Right); end; end; end else inherited; end; |
FTitleInfo — это экземпляр нашего вспомогательного класса. У него появилось свойство FrameRect, в котором хранится рассчитанный прямоугольник. Метод доступа по чтению свойства выглядит так:
|
1 2 3 4 5 6 7 8 9 10 |
function TFormTitleInfo.GetFrameRect: TRect; begin if FFrameRect.IsEmpty and (FOwner<>nil) then begin FOwner.HandleNeeded; if not FOwner.HandleAllocated then exit; FFrameRect := GetAdjustWindowRect(FOwner.Handle); end; Result := FFrameRect; end; |
FOwner — это форма, с которой проводим манипуляции. Для определения области панели задач служит следующий метод (надо включить в предложение uses модуль Winapi.ShellAPI):
|
1 2 3 4 5 6 7 8 9 |
class function TFormTitleInfo.GetTaskBarBounds: TRect; var D: TAppBarData; begin D.cbSize := SizeOf(D); if SHAppBarMessage(ABM_GETTASKBARPOS, D) > 0 then Result := D.rc else Result := TRect.Empty; end; |
Получаем следующее:
Верхняя половина заголовка исчезла. Системные кнопки переместились в нижнюю часть, встали вровень с компонентами. Замечаем, что перетаскивать форму за заголовок, или изменить размер мышкой сверху, мы не можем. Также замечаем отсутствие всяческой реакции на действия мыши в области системных кнопок. Это замечательно!
Таскаем за заголовок
Мы прекрасно знаем, как заставить окно думать, что мышка на самом деле в области заголовка. Нам нужно обработать сообщение WM_NCHITTEST. Заодно решим проблему с изменением размера сверху. И давайте тут же разрешим показывать системное меню, то самое, когда кликаешь на иконку окна.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
procedure TFmMain.WMNCHitTest(var Message: TWMNCHitTest); var P: TPoint; R: TRect; begin inherited; case Message.Result of HTCLIENT: begin // Координаты мыши в оконных координатах P := ScreenToClient(Point(Message.XPos, Message.YPos)); // Если мышь ниже заголовка, выходим if P.Y > GlassFrame.Top then exit; // Проверим область иконки для системного меню R := FTitleInfo.GetIconRect; if (P.X < R.Right) and ((WindowState = wsMaximized) or ((P.Y >= R.Top) and (P.Y < R.Bottom))) then // Попали в иконку, это область системного меню Message.Result := HTSYSMENU else if (P.Y < FTitleInfo.FrameRect.Right) and (BorderStyle in [bsSizeable, bsSizeToolWin]) then // Попали на верхнюю кромку, можно менять размер мышкой Message.Result := HTTOP else // Всё остальное - заголовок Message.Result := HTCAPTION; end; HTMINBUTTON, HTMAXBUTTON, HTCLOSE: begin // Не-не, всё остальное - заголовок Message.Result := HTCAPTION; exit; end; end; end; |
Чтобы определить область, где должна находиться иконка, в нашем вспомогательном классе предусмотрен метод GetIconRect:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 |
type TCustomFormWrapper = class(TCustomForm); class procedure TFormTitleInfo.GetIconRect(AForm: TCustomForm; const AFrameRect: TRect; out ARect: TRect); var Size: Integer; begin ARect := TRect.Empty; if (AForm=nil) or not (biSystemMenu in TCustomFormWrapper(AForm).BorderIcons) or not (AForm.BorderStyle in [bsSingle, bsSizeable]) then exit; if TOSVersion.Check(10) then if AForm.WindowState=wsMaximized then ARect.Left := IconWindowOffset else ARect.Left := AFrameRect.Right; {$IF CompilerVersion < 34} Size := GetSystemMetrics(SM_CXSMICON); {$ELSE} Size := GetSystemMetricsForWindow(SM_CXSMICON, AForm.Handle); {$ENDIF} ARect.Right := ARect.Left + Size; if (AForm.WindowState = wsMaximized) then ARect.Top := (Abs(AFrameRect.Top) - AFrameRect.Right - Size) div 2 else ARect.Top := (Abs(AFrameRect.Top) - Size) div 2; ARect.Bottom := ARect.Top + Size; end; function TFormTitleInfo.GetIconRect: TRect; begin GetIconRect(FOwner, FrameRect, Result); end; |
Видим, что теперь и стрелка сверху появилась, и заголовок стал таскабельным, и даже меню на клик есть:
Получив возможность таскать окно за заголовок, проверяем AeroSnap, и он работает. А вот компоненты и системные кнопки по прежнему не в лучшем виде. Всё просто зашибись!
Системные кнопки
Конечно, есть большой соблазн обработать координаты курсора и подсунуть в результат что-то типа HTMINBUTTON, HTMAXBUTTON, HTCLOSE. Но это даст только реакцию на клик, подсветки не будет. А хочется, чтобы системные кнопки подсвечивались так, как мы привыкли.
Для того, чтобы оживить системные кнопки, воспользуемся функцией DwmDefWindowProc из арсенала Dwm. В описании есть условия, при которых функция станет работать. Но мы считаем, что разработчики Delphi уже обо всём позаботились. В предложение uses надо добавить модуль Winapi.DwmApi. Чтобы воспользоваться данной функцией, переопределяем метод формы WndProc. Выглядеть он будет очень просто:
|
1 2 3 4 5 6 7 8 9 |
procedure TFmMain.WndProc(var Message: TMessage); begin if HandleAllocated and DwmDefWindowProc(Handle, Message.Msg, Message.WParam, Message.LParam, Message.Result) then exit; inherited; end; |
Что тут происходит. Перед анализом и рассылкой всех сообщений, мы скармливаем сообщение функции DwmDefWindowProc и если оно предназначалось Dwm и успешно обработано, то дальше не происходит ничего. Сообщение обработано, всё.
Теперь получаем привычную реакцию системных кнопок на мышь, подсказки и поведение. Кнопка подглючивает, но в целом отлично!
Имитация заголовка
Осталось вывести иконку и заголовок. В пустое место слева разместим TPaintBox. Куда ж без него. Обзовём pbTitle.
В обработчике OnCreate формы зададим нужные размеры и положение для pbTitle. Также установим DoubleBuffered в True. Тем самым, мы вылечим отображение компонент в заголовке.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
procedure TFmMain.FormCreate(Sender: TObject); begin Caption := 'IP76.RU: Form Tricks 2.1'; // Создаём вспомогательный класс FTitleInfo := TFormTitleInfo.Create(Self); FTitleInfo.UpdateGlassFrame; // Назначим область для отрисовки иконки и текст заголовка pbTitle.SetBounds(0, 0, ButtonedEdit1.Left, FTitleInfo.FrameRect.Height); // Для того, чтобы рамка окна рисовалась нормально, // выставим ширину не-клиентской области BorderWidth := FTitleInfo.FrameRect.Right; // Используем двойную буферизацию, чтобы компоненты не глючили DoubleBuffered := True; // Текущий стиль рамки окна ComboBox2.ItemIndex := Integer(BorderStyle); // Убираем высоту на величину съеденного заголовка if GlassFrame.Enabled then Height := Height - GlassFrame.Top; end; |
В нашем вспомогательном классе напишем два метода отрисовки иконки и текста заголовка. Для рисования иконки метод выглядит так:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 |
class procedure TFormTitleInfo.DrawTitleIcon(AForm: TCustomForm; ACanvas: TCanvas; const ARect: TRect); var h: HICON; Icon: TIcon; Size: Integer; bmp: TBitmap; begin if ARect.IsEmpty then exit; Size := ARect.Height; Icon := TIcon.Create; try if not TCustomFormWrapper(AForm).Icon.Empty then h := TCustomFormWrapper(AForm).Icon.Handle else h := Application.Icon.Handle; Icon.Handle := CopyImage(h, IMAGE_ICON, Size, Size, LR_COPYFROMRESOURCE); bmp := TBitmap.Create; try bmp.Assign(Icon); ACanvas.Draw(ARect.Left, ARect.Top, bmp); finally bmp.Free; end; finally Icon.Free; end; end; procedure TFormTitleInfo.DrawTitleIcon(ACanvas: TCanvas; out ARect: TRect); begin ARect := GetIconRect; DrawTitleIcon(FOwner, ACanvas, ARect); end; |
Что тут происходит. Забираем иконку либо у формы, либо у приложения, преобразуем в битмап и рисуем. Иначе, при двойной буферизации, которую мы включили, могут наблюдаться глюки.
Для отрисовки заголовка служит метод:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
class procedure TFormTitleInfo.DrawTitleCaption(AForm: TCustomForm; ACanvas: TCanvas; const AFrameRect: TRect; var ARect: TRect); const CaptionColors: array[Boolean] of TColor = (clBtnShadow{clInActiveCaptionText}, clCaptionText); var StyleTextOptions: TStyleTextOptions; NonClientMetrics: TNonClientMetrics; begin ARect.Top := 0; if (AForm.WindowState = wsMaximized) then ARect.Bottom := Abs(AFrameRect.Top) - AFrameRect.Right else ARect.Bottom := -AFrameRect.Top; ARect.Left := ARect.Left + IconTextMargin; FillChar(NonClientMetrics, SizeOf(NonClientMetrics), 0); NonClientMetrics.cbSize := SizeOf(NonClientMetrics); {$IF CompilerVersion < 34} if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, SizeOf(NonClientMetrics), @NonClientMetrics, 0) {$ELSE} if SystemParametersInfoForWindow(SPI_GETNONCLIENTMETRICS, SizeOf(NonClientMetrics), @NonClientMetrics, 0, AForm.Handle) {$ENDIF} then if AForm.BorderStyle in [bsToolWindow, bsSizeToolWin] then ACanvas.Font.Handle := CreateFontIndirect(NonClientMetrics.lfSmCaptionFont) else ACanvas.Font.Handle := CreateFontIndirect(NonClientMetrics.lfCaptionFont); StyleTextOptions.Flags := [stfTextColor]; StyleTextOptions.TextColor := CaptionColors[AForm.Active]; TStyleManager.SystemStyle.DrawText(ACanvas.Handle, TStyleManager.SystemStyle.GetElementDetails(twCaptionActive), AForm.Caption, ARect, [tfSingleLine, tfLeft, tfVerticalCenter, tfEndEllipsis, tfComposited], StyleTextOptions); end; procedure TFormTitleInfo.DrawTitleCaption(ACanvas: TCanvas; var ARect: TRect); begin DrawTitleCaption(FOwner, ACanvas, FrameRect, ARect); end; |
Если кому-то захочется разместить текст по центру, сделать его пурпурным или трёхмерным, то надо просто переписать метод, добавить выравнивание, свои цвета. Сейчас просто демонстрирую сам метод, без красот.
Обработчик события OnPaint нашего pbTitle выглядит так:
|
1 2 3 4 5 6 7 8 |
procedure TFmMain.pbTitlePaint(Sender: TObject); var rct: TRect; begin FTitleInfo.DrawTitleIcon(pbTitle.Canvas, rct); rct.Left := rct.Right; rct.Right := pbTitle.BoundsRect.Right; FTitleInfo.DrawTitleCaption(pbTitle.Canvas, rct); end; |
И вот что получилось:
В принципе, получили то, чего хотели. Теперь про красоту.
Cтиль рамки окна и серая полоса
Вряд ли в процессе работы одно и то же окно будет впадать в разные стили. Поэтому обрабатывать виндусовые сообщения не будем, просто добавим список возможных значений в крайний справа ComboBox и обработаем событие OnChange.
|
1 2 3 4 5 6 |
procedure TFmMain.ComboBox2Change(Sender: TObject); begin BorderStyle := TFormBorderStyle(ComboBox2.ItemIndex); FTitleInfo.UpdateGlassFrame; pbTitle.SetBounds(0, 0, ButtonedEdit1.Left, FTitleInfo.FrameRect.Height); end; |
Есть один неприятный момент, на который многие жалуются. Речь идёт о тонкой линии, толщиной в пиксель, которая обрамляет заголовок снизу и выглядит, как баг. Сделаем цвет окна белым. На белом это будет хорошо видно.
Вот она. Может проявиться на nonsizeable стилях рамки окна.
Или так. Едва различимая светло-серая линия в sizeable стилях. Некоторых бесит.
Чтобы решить проблему, немного изменим метод UpdateGlassFrame нашего вспомогательного класса.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
class procedure TFormTitleInfo.UpdateGlassFrame(AForm: TCustomForm; out ARect: TRect); begin ARect := TRect.Empty; if AForm = nil then exit; AForm.HandleNeeded; if not AForm.HandleAllocated then exit; ARect := GetAdjustWindowRect(AForm.Handle); if AForm.BorderStyle in [bsNone, bsSizeable, bsSizeToolWin] then // если тут сделать +1, будет видна едва заметная серая полоса AForm.GlassFrame.Top := -ARect.Top else // +1, боремся с полосой в 1 пиксел при nonsizeable стилях AForm.GlassFrame.Top := -ARect.Top + 1; AForm.GlassFrame.Enabled := True; SetWindowPos(AForm.Handle, 0, AForm.Left, AForm.Top, AForm.Width, AForm.Height, SWP_FRAMECHANGED or SWP_NOACTIVATE); end; |
Добавим настройки видимости системных кнопок, чтобы посмотреть на их поведение и отображение.
Если мы выставим свойство BorderIcons := [biSystemMenu, biHelp], то кнопка помощи будет видна и при стилях Single и Sizeable, не только в диалоге. Ну… так устроен Windows… Кнопка помощи появляется только тогда, когда нет кнопок минимизации и максимизации. Чтобы видеть весь комплект системных кнопок, люди и творят зло TitleBarPanel.
У окна может смениться иконка, текст заголовка. К сожалению, эту часть мы рисуем руками, поэтому нужно вовремя реагировать и перерисовывать. Обработаем три события. Их список может вырасти при необходимости, но этих трёх в большинстве случаев достаточно:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
procedure TFmMain.WMActivate(var Message: TWMActivate); begin inherited; if pbTitle <> nil then pbTitle.Invalidate; end; procedure TFmMain.WMSetText(var Message: TWMSetText); begin inherited; if pbTitle <> nil then pbTitle.Invalidate; end; procedure TFmMain.WMSetIcon(var Message: TWMSetIcon); begin inherited; if pbTitle <> nil then pbTitle.Invalidate; end; |
Проверяем тем, что кликаем на картинки в форме
|
1 2 3 4 |
procedure TFmMain.Image1Click(Sender: TObject); begin Icon := TImage(Sender).Picture.Icon; end; |
или по кнопке Apply:
|
1 2 3 4 |
procedure TFmMain.Button1Click(Sender: TObject); begin Caption := 'IP76.RU: ' + ButtonedEdit1.Text; end; |
Видим, что иконка окна меняется, заголовок тоже, события отрабатывают. Более того, неуместившийся заголовок правильно нарисовался, с точками.
Delphi 12
Выше мы предусмотрели тот факт, что Delphi, начиная с 10.4, всё лучше и лучше воспринимает высокое разрешение и всё, что с ним связано. Надо посмотреть, правильно ли мы предусмотрели, да и вообще, любопытно. Берём тот же самый исходник и компилируем в Delphi 12. И видим, что баги, наблюдаемые при TitleBarPanel, это баги не только TitleBarPanel.
TButton ведёт себя плохо. Но это можно вылечить. Надо либо выставить в инспекторе объектов, либо руками прописать следующее:
|
1 |
Button1.DoubleBufferedMode := dbmRequested; |
Ожидания по качественному тексту в заголовке на первый взгляд не оправдались. Идём в настройки проекта, смотрим Application — Manifest — DPI Awareness и видим, что там… пусто. Выбираем из списка Per Monitor v2, и вуаля! — заголовок стал выглядеть просто чудо как хорошо.
Недостатки
- В таком окне TMainMenu попадает туда же, куда и заголовок. То есть, в никуда. Его не видно. Но можно использовать TActionMainMenuBar. Вполне себе современное решение.
- В текущей реализации нельзя использовать стили. Сразу появляется стильный заголовок и всё портит. Чтобы стильный заголовок не появлялся, надо убрать seBorder из свойства StyleElements формы. Подробнее опишу в следующей статье.
- Только Windows 10 и выше. Под Windows 7 работает, но выглядит грустно. Поэтому, при запуске надо анализировать, какая ОС, и, в зависимости от этого, либо делать манипуляции с заголовком, либо оставить всё как есть.
Листинги
Привожу полные листинги, потому что копипастить удобней, чем качать, и всё вместе наглядней, чем фрагментарно. Получилось совсем немного, примерно по 250 строк на каждый модуль.
Вспомогательный класс
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 |
//****************************************************************************** // Project: IP76.RU // Created: 2024-08-10 // Article: https://ip76.ru/edit-into-title // Описание: Вспомогательный класс для размещение элементов управления // в заголовке окна //****************************************************************************** unit IP76.FormTitleInfo; interface uses Winapi.Windows, Winapi.ShellAPi, System.SysUtils, System.Types, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.ExtCtrls, Vcl.Themes; type TFormTitleInfo = class public const IconWindowOffset = 2; IconTextMargin = 5; private FOwner: TCustomForm; FFrameRect: TRect; function GetFrameRect: TRect; public // Получить прямоугольник области панели задач class function GetTaskBarBounds: TRect; static; // Получить смещения по краям окна class function GetAdjustWindowRect(AHandle: HWND): TRect; static; // Получить прямоугольник иконки в заголовке окна class procedure GetIconRect(AForm: TCustomForm; const AFrameRect: TRect; out ARect: TRect); overload; static; // Обновить GlassFrame формы и заставить окно применить изменения class procedure UpdateGlassFrame(AForm: TCustomForm; out ARect: TRect); overload; static; // Нарисовать иконку окна class procedure DrawTitleIcon(AForm: TCustomForm; ACanvas: TCanvas; const ARect: TRect); overload; static; // Нарисовать титл окна class procedure DrawTitleCaption(AForm: TCustomForm; ACanvas: TCanvas; const AFrameRect: TRect; var ARect: TRect); overload; static; procedure UpdateGlassFrame; overload; function GetIconRect: TRect; overload; procedure DrawTitleIcon(ACanvas: TCanvas; out ARect: TRect); overload; procedure DrawTitleCaption(ACanvas: TCanvas; var ARect: TRect); overload; public constructor Create(AOwner: TCustomForm); property FrameRect: TRect read GetFrameRect; end; implementation uses System.Math; {TFormTitleInfo} constructor TFormTitleInfo.Create(AOwner: TCustomForm); begin FOwner := AOwner; FFrameRect := TRect.Empty; end; function TFormTitleInfo.GetFrameRect: TRect; begin if FFrameRect.IsEmpty and (FOwner<>nil) then begin FOwner.HandleNeeded; if not FOwner.HandleAllocated then exit; FFrameRect := GetAdjustWindowRect(FOwner.Handle); end; Result := FFrameRect; end; class function TFormTitleInfo.GetTaskBarBounds: TRect; var D: TAppBarData; begin D.cbSize := SizeOf(D); if SHAppBarMessage(ABM_GETTASKBARPOS, D) > 0 then Result := D.rc else Result := TRect.Empty; end; class function TFormTitleInfo.GetAdjustWindowRect(AHandle: HWND): TRect; var dwStyle, dwExStyle: DWORD; begin Result := TRect.Empty; dwStyle := GetWindowLong(AHandle, GWL_STYLE); dwExStyle := GetWindowLong(AHandle, GWL_EXSTYLE); {$IF CompilerVersion < 34} AdjustWindowRectEx(Result, dwStyle, False, dwExStyle); {$ELSE} // Версия Delphi 10.4 и выше // Местонахождение: Vcl.Controls AdjustWindowRectExForWindow(Result, dwStyle, False, dwExStyle, AHandle); {$ENDIF} end; type TCustomFormWrapper = class(TCustomForm); class procedure TFormTitleInfo.GetIconRect(AForm: TCustomForm; const AFrameRect: TRect; out ARect: TRect); var Size: Integer; begin ARect := TRect.Empty; if (AForm=nil) or not (biSystemMenu in TCustomFormWrapper(AForm).BorderIcons) or not (AForm.BorderStyle in [bsSingle, bsSizeable]) then exit; if TOSVersion.Check(10) then if AForm.WindowState=wsMaximized then ARect.Left := IconWindowOffset else ARect.Left := AFrameRect.Right; {$IF CompilerVersion < 34} Size := GetSystemMetrics(SM_CXSMICON); {$ELSE} Size := GetSystemMetricsForWindow(SM_CXSMICON, AForm.Handle); {$ENDIF} ARect.Right := ARect.Left + Size; if (AForm.WindowState = wsMaximized) then ARect.Top := (Abs(AFrameRect.Top) - AFrameRect.Right - Size) div 2 else ARect.Top := (Abs(AFrameRect.Top) - Size) div 2; ARect.Bottom := ARect.Top + Size; end; class procedure TFormTitleInfo.UpdateGlassFrame(AForm: TCustomForm; out ARect: TRect); begin ARect := TRect.Empty; if AForm = nil then exit; AForm.HandleNeeded; if not AForm.HandleAllocated then exit; ARect := GetAdjustWindowRect(AForm.Handle); if AForm.BorderStyle in [bsNone, bsSizeable, bsSizeToolWin] then // если тут сделать +1, будет видна едва заметная серая полоса AForm.GlassFrame.Top := -ARect.Top else // +1, боремся с полосой в 1 пиксел при nonsizeable стилях AForm.GlassFrame.Top := -ARect.Top + 1; AForm.GlassFrame.Enabled := True; SetWindowPos(AForm.Handle, 0, AForm.Left, AForm.Top, AForm.Width, AForm.Height, SWP_FRAMECHANGED or SWP_NOACTIVATE); end; class procedure TFormTitleInfo.DrawTitleIcon(AForm: TCustomForm; ACanvas: TCanvas; const ARect: TRect); var h: HICON; Icon: TIcon; Size: Integer; bmp: TBitmap; begin if ARect.IsEmpty then exit; Size := ARect.Height; Icon := TIcon.Create; try if not TCustomFormWrapper(AForm).Icon.Empty then h := TCustomFormWrapper(AForm).Icon.Handle else h := Application.Icon.Handle; Icon.Handle := CopyImage(h, IMAGE_ICON, Size, Size, LR_COPYFROMRESOURCE); bmp := TBitmap.Create; try bmp.Assign(Icon); ACanvas.Draw(ARect.Left, ARect.Top, bmp); finally bmp.Free; end; finally Icon.Free; end; end; class procedure TFormTitleInfo.DrawTitleCaption(AForm: TCustomForm; ACanvas: TCanvas; const AFrameRect: TRect; var ARect: TRect); const CaptionColors: array[Boolean] of TColor = (clBtnShadow{clInActiveCaptionText}, clCaptionText); var StyleTextOptions: TStyleTextOptions; NonClientMetrics: TNonClientMetrics; begin ARect.Top := 0; if (AForm.WindowState = wsMaximized) then ARect.Bottom := Abs(AFrameRect.Top) - AFrameRect.Right else ARect.Bottom := -AFrameRect.Top; ARect.Left := ARect.Left + IconTextMargin; FillChar(NonClientMetrics, SizeOf(NonClientMetrics), 0); NonClientMetrics.cbSize := SizeOf(NonClientMetrics); {$IF CompilerVersion < 34} if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, SizeOf(NonClientMetrics), @NonClientMetrics, 0) {$ELSE} if SystemParametersInfoForWindow(SPI_GETNONCLIENTMETRICS, SizeOf(NonClientMetrics), @NonClientMetrics, 0, AForm.Handle) {$ENDIF} then if AForm.BorderStyle in [bsToolWindow, bsSizeToolWin] then ACanvas.Font.Handle := CreateFontIndirect(NonClientMetrics.lfSmCaptionFont) else ACanvas.Font.Handle := CreateFontIndirect(NonClientMetrics.lfCaptionFont); StyleTextOptions.Flags := [stfTextColor]; StyleTextOptions.TextColor := CaptionColors[AForm.Active]; TStyleManager.SystemStyle.DrawText(ACanvas.Handle, TStyleManager.SystemStyle.GetElementDetails(twCaptionActive), AForm.Caption, ARect, [tfSingleLine, tfLeft, tfVerticalCenter, tfEndEllipsis, tfComposited], StyleTextOptions); end; function TFormTitleInfo.GetIconRect: TRect; begin GetIconRect(FOwner, FrameRect, Result); end; procedure TFormTitleInfo.UpdateGlassFrame; begin if FOwner=nil then exit; UpdateGlassFrame(FOwner, FFrameRect); end; procedure TFormTitleInfo.DrawTitleIcon(ACanvas: TCanvas; out ARect: TRect); begin ARect := GetIconRect; DrawTitleIcon(FOwner, ACanvas, ARect); end; procedure TFormTitleInfo.DrawTitleCaption(ACanvas: TCanvas; var ARect: TRect); begin DrawTitleCaption(FOwner, ACanvas, FrameRect, ARect); end; end. |
Модуль формы
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 |
//****************************************************************************** // Project: IP76.RU // Created: 2024-08-10 // Article: https://ip76.ru/edit-into-title // Описание: Размещение элементов управления в заголовке окна // Сохранение системных кнопок окна // Без использования Panel, TitleBarPanel и прочих фокусов //****************************************************************************** unit UnMain; interface uses Winapi.Windows, Winapi.Messages, Winapi.ShellAPi, Winapi.DwmApi, System.SysUtils, System.Classes, System.Types, Vcl.Graphics, Vcl.Controls, Vcl.Dialogs, Vcl.Forms, Vcl.ExtCtrls, Vcl.ImgList, Vcl.StdCtrls, Vcl.Buttons, Vcl.Themes, IP76.FormTitleInfo; type TFmMain = class(TForm) ButtonedEdit1: TButtonedEdit; ImageList1: TImageList; ComboBox1: TComboBox; Button1: TButton; Image1: TImage; Image2: TImage; pbTitle: TPaintBox; ComboBox2: TComboBox; Image3: TImage; Bevel1: TBevel; CheckBox1: TCheckBox; CheckBox2: TCheckBox; CheckBox3: TCheckBox; CheckBox4: TCheckBox; Label1: TLabel; Image4: TImage; Label6: TLabel; Label2: TLabel; procedure ButtonedEdit1RightButtonClick(Sender: TObject); procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure pbTitlePaint(Sender: TObject); procedure Image1Click(Sender: TObject); procedure ComboBox2Change(Sender: TObject); procedure CheckBox1Click(Sender: TObject); procedure Label6Click(Sender: TObject); private FTitleInfo: TFormTitleInfo; procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE; procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE; procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT; procedure WMSetIcon(var Message: TWMSetIcon); message WM_SETICON; protected procedure WndProc(var Message: TMessage); override; end; var FmMain: TFmMain; implementation {$R *.dfm} {TFmMain} {$Region 'Конструктор/деструктор'} procedure TFmMain.FormCreate(Sender: TObject); begin Caption := 'IP76.RU: Form Tricks 2.1'; Label6.Hint := 'https://ip76.ru/edit-into-title'; // Создаём вспомогательный класс FTitleInfo := TFormTitleInfo.Create(Self); FTitleInfo.UpdateGlassFrame; // Назначим область для отрисовки иконки и текст заголовка pbTitle.SetBounds(0, 0, ButtonedEdit1.Left, FTitleInfo.FrameRect.Height); // Для того, чтобы рамка окна рисовалась нормально, // выставим ширину не-клиентской области BorderWidth := FTitleInfo.FrameRect.Right; // Используем двойную буферизацию, чтобы компоненты не глючили DoubleBuffered := True; // Текущий стиль рамки окна ComboBox2.ItemIndex := Integer(BorderStyle); // Убираем высоту на величину съеденного заголовка if GlassFrame.Enabled then Height := Height - GlassFrame.Top; // Для демонстрации мерзкой серой полосы установим белый цвет окна Color := clWindow; end; procedure TFmMain.FormDestroy(Sender: TObject); begin FreeAndNil(FTitleInfo); end; {$EndRegion} {$Region 'Простые методы формы'} procedure TFmMain.Image1Click(Sender: TObject); begin Icon := TImage(Sender).Picture.Icon; end; procedure TFmMain.Label6Click(Sender: TObject); begin ShellExecute(Handle,'open', PChar(Label6.Hint), nil, nil, SW_NORMAL); end; procedure TFmMain.Button1Click(Sender: TObject); begin Caption := 'IP76.RU: ' + ButtonedEdit1.Text; end; procedure TFmMain.ButtonedEdit1RightButtonClick(Sender: TObject); begin ShowMessage(ButtonedEdit1.TextHint.TrimRight(['.'])+': '+ButtonedEdit1.Text); end; procedure TFmMain.CheckBox1Click(Sender: TObject); var bs: TBorderIcons; begin bs := []; if CheckBox1.Checked then bs := bs + [biSystemMenu]; if CheckBox2.Checked then bs := bs + [biMinimize]; if CheckBox3.Checked then bs := bs + [biMaximize]; if CheckBox4.Checked then bs := bs + [biHelp]; BorderIcons := bs end; procedure TFmMain.ComboBox2Change(Sender: TObject); begin BorderStyle := TFormBorderStyle(ComboBox2.ItemIndex); FTitleInfo.UpdateGlassFrame; pbTitle.SetBounds(0, 0, ButtonedEdit1.Left, FTitleInfo.FrameRect.Height); end; {$EndRegion} {$Region 'Обработчики Windows-событий'} procedure TFmMain.WMNCCalcSize(var Message: TWMNCCalcSize); var M: TMonitor; rct: TRect; Params: PNCCalcSizeParams; begin if (FTitleInfo<>nil) and (WindowState <> wsMinimized) and Message.CalcValidRects then begin Params := Message.CalcSize_Params; Inc(Params.rgrc[0].Left, FTitleInfo.FrameRect.Right); Dec(Params.rgrc[0].Right, FTitleInfo.FrameRect.Right); Dec(Params.rgrc[0].Bottom, FTitleInfo.FrameRect.Right); if WindowState = wsMaximized then begin M := Monitor; if (M = Screen.PrimaryMonitor) and (M.WorkareaRect = M.BoundsRect) then begin rct := TFormTitleInfo.GetTaskBarBounds; if not rct.IsEmpty then if rct.Width > rct.Height then Dec(Params.rgrc[0].Bottom) else Dec(Params.rgrc[0].Right); end; end; end else inherited; end; procedure TFmMain.WMNCHitTest(var Message: TWMNCHitTest); var P: TPoint; R: TRect; begin inherited; case Message.Result of HTCLIENT: begin // Координаты мыши в оконных координатах P := ScreenToClient(Point(Message.XPos, Message.YPos)); // Если мышь ниже заголовка, выходим if P.Y > GlassFrame.Top then exit; // Проверим область иконки для системного меню R := FTitleInfo.GetIconRect; if (P.X < R.Right) and ((WindowState = wsMaximized) or ((P.Y >= R.Top) and (P.Y < R.Bottom))) then // Попали в иконку, это област системного меню Message.Result := HTSYSMENU else if (P.Y < FTitleInfo.FrameRect.Right) and (BorderStyle in [bsSizeable, bsSizeToolWin]) then // Попали на верхнюю кромку, можно менять размер мышкой Message.Result := HTTOP else // Всё остальное - заголовок Message.Result := HTCAPTION; end; HTMINBUTTON, HTMAXBUTTON, HTCLOSE: begin // Не-не, всё остальное - заголовок Message.Result := HTCAPTION; exit; end; end; end; procedure TFmMain.WMActivate(var Message: TWMActivate); begin inherited; if pbTitle <> nil then pbTitle.Invalidate; end; procedure TFmMain.WMSetText(var Message: TWMSetText); begin inherited; if pbTitle <> nil then pbTitle.Invalidate; end; procedure TFmMain.WMSetIcon(var Message: TWMSetIcon); begin inherited; if pbTitle <> nil then pbTitle.Invalidate; end; {$EndRegion} procedure TFmMain.WndProc(var Message: TMessage); begin if HandleAllocated and DwmDefWindowProc(Handle, Message.Msg, Message.WParam, Message.LParam, Message.Result) then exit; inherited; end; procedure TFmMain.pbTitlePaint(Sender: TObject); var rct: TRect; begin FTitleInfo.DrawTitleIcon(pbTitle.Canvas, rct); rct.Left := rct.Right; rct.Right := pbTitle.BoundsRect.Right; FTitleInfo.DrawTitleCaption(pbTitle.Canvas, rct); end; end. |
Тёмная тема в Delphi
Стили Vcl умеют закрашивать заголовок, но не позволяют разместить там компоненты. Форма не понимает тёмную тему Windows и заголовок остаётся белым. Как быть? Обо всём в следующей статье: Трюки с формой 2.2.1: Тёмная тема Windows в Delphi 12.
Скачать
Друзья, спасибо за внимание! Надеюсь, материал пригодится )))
Исходник (zip) 188 Кб. Delphi XE 7, XE 12
Исполняемый файл (zip) 901 Кб (Скомпилирован в XE 7)
Исполняемый файл (zip) 0.98 Мб (Скомпилирован в XE 12)