Тёмная тема Windows доступна и в XE 7. Но, так как эта версия Delphi создавалась во времена Windows 7, то ни о каком High-DPI, ни о каких тёмных темах, тогда ещё речи не было. Между тем, всё возможно.
Эта статья — продолжение разговора, начатого в статье: «Трюки с формой 2.2.1: Тёмная тема Windows в Delphi 12». Все основные приёмы описаны там. Здесь описаны нюансы именно для XE 7. Для понимания материала, лучше начать со статьи 2.2.1.
Подготовка
Копируем проект для XE 7 из статьи «Трюки с формой 2.1: Edit в заголовке окна». Из предыдущей статьи «Трюки с формой 2.2.1: Тёмная тема Windows в Delphi 12» забираем два файла: UnMain.pas и IP76.FormTitleInfo.pas, и бросаем поверх существующих. При компиляции будет ругань на System.ImageList. Просто удаляем его из uses.
Для Delphi 12 мы использовали стиль Windows10 Dark. В XE 7 его нет, поэтому копируем его:
- Идём в каталог установки Delphi12 \Program Files (x86)\Embarcadero\Studio\23.0\Redist\styles\vcl\
- Копируем Windows10Dark.vsf
- Идём в каталог \Users\Public\Documents\Embarcadero\Studio\15.0\Styles
- Вставляем туда ранее скопированный Windows10Dark.vsf
Теперь он есть в списке стилей, включаем галочку, оставляем стиль по умолчанию Windows. Об этом говорилось в предыдущей статье.
Делаем ComboBox1.Style := csDropDownList. Проверяем, есть ли реакция на событие OnChange, если нет, в инспекторе выбираем для ComboBox1.OnChange существующий ComboBox1Change.
Для всех компонент, которые должны быть в заголовке, выставим Anchors := [akTop,akRight], чтобы при изменении размера формы они оставались у системных кнопок.
|
1 2 3 4 5 6 7 |
procedure TFmMain.FormShow(Sender: TObject); begin Button1.Anchors := [akTop, akRight]; ComboBox2.Anchors := [akTop, akRight]; ComboBox1.Anchors := [akTop, akRight]; ButtonedEdit1.Anchors := [akTop, akRight]; end; |
Запускаем. В светлой теме всё прекрасно:
Переключаем в тёмную:
Видим какие-то левые кнопки выпадающих списков и отсутствие системных кнопок. Первое мы вылечим сменой стиля, второе – сменой ловушки на стиль.
Меняем стиль тёмной темы
Стиль, который мы позаимствовали из Delphi 12, отличается от стилей XE 7 как минимум тем, что он поддерживает высокое разрешение, про которое XE 7 ничего не знает. Поэтому, уберём его из используемых стилей и выберем стиль Carbon.
Cтиль по умолчанию должен остаться Windows. Меняем наименование стиля для тёмной темы в обработчике OnChange для ComboBox1:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 |
procedure TFmMain.ComboBox1Change(Sender: TObject); begin FStyleChanging := (ComboBox1.ItemIndex=0) and TStyleManager.IsCustomStyleActive or (ComboBox1.ItemIndex<>0) and not TStyleManager.IsCustomStyleActive; if not FStyleChanging then exit; if ComboBox1.ItemIndex=0 then TStyleManager.TrySetStyle('Windows') else // TStyleManager.TrySetStyle('Windows10 Dark') ; TStyleManager.TrySetStyle('Carbon') ; end; |
Стало получше. Системных кнопок нет.
Меняем ловушку стиля
Посмотрев, как реализована ловушка стиля для TCustomForm, обнаружим, что смещение для заголовка GlassForm.Top там не учитывается совершенно. Поэтому немного меняем ловушку. Нас всё устраивает, только хотим чуть-чуть изменить отрисовку фона.
|
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 |
type TFormStyleHookEx = class(TFormStyleHook) strict protected procedure PaintBackground(Canvas: TCanvas); override; end; procedure TFormStyleHookEx.PaintBackground(Canvas: TCanvas); var Details: TThemedElementDetails; S: TCustomStyleServices; R: TRect; begin S := StyleServices; if S.Available then begin Details.Element := teWindow; Details.Part := 0; if Form.GlassFrame.Enabled then R := Rect(Form.GlassFrame.Left, Form.GlassFrame.Top, Control.ClientWidth - Form.GlassFrame.Right, Control.ClientHeight - Form.GlassFrame.Bottom) else R := Rect(0, 0, Control.ClientWidth, Control.ClientHeight); S.DrawElement(Canvas.Handle, Details, R); end; end; |
В Delphi 12 всё давным-давно учтено, поэтому этот нюанс касается только до-TitleBarPanel версий.
В обработчике OnCreate формы добавим такую строку:
|
1 |
TCustomStyleEngine.RegisterStyleHook(TCustomForm, TFormStyleHookEx); |
И наблюдаем явное улучшение:
Есть баг на кнопке ButtonEdit1 – белое поле, но это уже вопросы к стилю. Это частности, решаемые в частном порядке. Например, переходом на более свежие версии.
Максимизация окна
Баги отрисовки
Если несколько раз максимизировать окно и вернуть обратно, то либо сразу, либо через пару раз, появится баг в заголовке:
Немного сместился текст заголовка и «клиентское» поле формы заехало в «заголовок». Если свернуть и развернуть окно, то всё пропадает. Также, если изменить размер, эффект тот же. Но ни эмуляция перечисленного, ни попытка что-либо изменить в ловушке стиля, ничего не помогает.
Лечим таким образом. В обработчике OnPaint формы пишем следующее:
|
1 2 3 4 5 6 7 8 |
procedure TFmMain.FormPaint(Sender: TObject); begin if FormIsDarkMode then begin Canvas.Brush.Color := Color; Canvas.FillRect(ClientRect); end; end; |
И всё заработало. Заголовок стал цвета стиля.
Вот теперь почти всё хорошо.
Верхнее выравнивание
Конечно, это к тёмной теме отношения мало имеет. Дело в том, что при максимизированном состоянии, наши компоненты в заголовке могут уехать за пределы монитора куда-то вверх.
Придётся выравнивать компоненты руками для разных стилей окна. Для этого переопределим метод Resize и учтём, что в процессе смены цветовой темы ничего менять не надо:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
procedure TFmMain.Resize; var dy: Integer; begin // В процессе смены стиля он тут вызовется раз несколько // А нам нужен последний, после сообщения о смене стиля if FStyleChanging then exit; // Для минимизированного окна не делаем ничего if WindowState = wsMinimized then exit; if WindowState = wsMaximized then dy := FTitleInfo.FrameRect.Right div 2 else dy := 0; // Выровняли поле заголовка pbTitle.SetBounds(0, dy*2, ButtonedEdit1.Left, -FTitleInfo.FrameRect.Top); // Отцентровали компоненты заголовка if BorderStyle = bsNone then exit; ButtonedEdit1.Top :=(-FTitleInfo.FrameRect.Top-ButtonedEdit1.Height) div 2+dy; ComboBox1.Top := ButtonedEdit1.Top; ComboBox2.Top := ButtonedEdit1.Top; Button1.Top := ButtonedEdit1.Top; Button1.Height := ButtonedEdit1.Height; // Генерация события OnResize inherited; end; |
Теперь выравнивание по верхнему краю работает как надо.
Следует отметить, что для Delphi 12 это не актуально. Введя в обиход TitleBarPanel, они перестали менять высоту заголовка для разных стилей окна. Между тем, в аналогичном проекте для Delphi 12, этот метод существует в таком же виде. Как минимум, чтобы выровнять pbTitle по крайнему левому компоненту, ну и просто это правильно, учитывать нюансы.
Листинги
Привожу на этот раз только модуль формы, во вспомогательном классе ничего не изменилось по сравнению с предыдущей статьей.
Модуль формы
|
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 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
//****************************************************************************** // Project: IP76.RU // Created: 2024-08-10 // Article: https://ip76.ru/dark-mode-formd15 // Описание: Размещение элементов управления в заголовке окна // Сохранение системных кнопок окна // Без использования Panel, TitleBarPanel и прочих фокусов // Тёмная тема Windows //****************************************************************************** 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; CheckBox1: TCheckBox; CheckBox2: TCheckBox; CheckBox3: TCheckBox; CheckBox4: TCheckBox; Label1: TLabel; Image4: TImage; Label6: TLabel; Bevel1: TBevel; 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); procedure ComboBox1Change(Sender: TObject); procedure FormPaint(Sender: TObject); procedure FormShow(Sender: TObject); private // Меняется ли сейчас стиль FStyleChanging: Boolean; // Информация по заголовку 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; // Изменились настройки Windows procedure WMSettingChange(var Message: TWMSettingChange); message WM_SETTINGCHANGE; protected procedure WndProc(var Message: TMessage); override; // Проверить и установить текущую тему Windows procedure CheckWindowTheme; // В тёмной ли теме форма function FormIsDarkMode: Boolean; // Метод при изменении размера, стиля окна // Переопределён для косметики - выравнивание контролов в заголовке procedure Resize; override; // Обработчик при изменении стиля procedure DoStyleChange; end; var FmMain: TFmMain; implementation {$R *.dfm} { TFormStyleHookEx } {$Region 'Стилевая ловушка для TCustomForm'} type TFormStyleHookEx = class(TFormStyleHook) strict protected procedure PaintBackground(Canvas: TCanvas); override; end; procedure TFormStyleHookEx.PaintBackground(Canvas: TCanvas); var Details: TThemedElementDetails; S: TCustomStyleServices; R: TRect; begin S := StyleServices; if S.Available then begin Details.Element := teWindow; Details.Part := 0; if Form.GlassFrame.Enabled then R := Rect(Form.GlassFrame.Left, Form.GlassFrame.Top, Control.ClientWidth - Form.GlassFrame.Right, Control.ClientHeight - Form.GlassFrame.Bottom) else R := Rect(0, 0, Control.ClientWidth, Control.ClientHeight); S.DrawElement(Canvas.Handle, Details, R); end; end; {$EndRegion} {TFmMain} {$Region 'Конструктор/деструктор'} procedure TFmMain.FormCreate(Sender: TObject); begin TCustomStyleEngine.RegisterStyleHook(TCustomForm, TFormStyleHookEx); FTitleInfo := TFormTitleInfo.Create(Self); FTitleInfo.UpdateGlassFrame; Caption := 'IP76.RU: Form Tricks 2.2.2'; Label6.Hint := 'https://ip76.ru/dark-mode-formD15'; ButtonedEdit1.Text := 'Dark Mode XE 7'; // Чтобы не было артефактов не-клиентской рамки BorderWidth := FTitleInfo.FrameRect.Right; // Чтобы убрать стильный заголовок StyleElements := [seFont, seClient]; // Поправка на съеденный заголовок if GlassFrame.Enabled then Height := Height - GlassFrame.Top; // Чтобы в целом нормально отрисовывало DoubleBuffered := True; {$IF CompilerVersion < 34} // Ничего не делаем {$ELSE} // Чтобы кнопка нормально отрисовывалась Button1.DoubleBufferedMode := dbmRequested; {$ENDIF} // Выставляем значение стиля рамки ComboBox2.ItemIndex := Integer(BorderStyle); // Определяем текущую тему ОС CheckWindowTheme; end; procedure TFmMain.FormDestroy(Sender: TObject); begin FreeAndNil(FTitleInfo); end; {$EndRegion} {$Region 'Переключение между темами'} procedure TFmMain.FormShow(Sender: TObject); begin // Меняем выравнивание по правому краю Button1.Anchors := [akTop, akRight]; ComboBox2.Anchors := [akTop, akRight]; ComboBox1.Anchors := [akTop, akRight]; ButtonedEdit1.Anchors := [akTop, akRight]; end; function TFmMain.FormIsDarkMode: Boolean; begin Result := ComboBox1.ItemIndex>0; end; procedure TFmMain.FormPaint(Sender: TObject); begin if FormIsDarkMode then begin Canvas.Brush.Color := Color; Canvas.FillRect(ClientRect); end; end; procedure TFmMain.DoStyleChange; begin FStyleChanging := False; TFormTitleInfo.SetDarkMode(Handle, FormIsDarkMode); FTitleInfo.UpdateGlassFrame; // if FormIsDarkMode then // Color := TStyleManager.ActiveStyle.GetStyleColor(scBorder) // else Color := TStyleManager.ActiveStyle.GetStyleColor(scWindow); end; procedure TFmMain.Resize; var dy: Integer; begin // В процессе смены стиля он тут вызовется раз несколько // А нам нужен последний, после сообщения о смене стиля if FStyleChanging then exit; // Для минимизированного окна не делаем ничего if WindowState = wsMinimized then exit; if WindowState = wsMaximized then dy := FTitleInfo.FrameRect.Right div 2 else dy := 0; // Выровняли поле заголовка pbTitle.SetBounds(0, dy*2, ButtonedEdit1.Left, -FTitleInfo.FrameRect.Top); // Отцентровали компоненты заголовка if BorderStyle = bsNone then exit; ButtonedEdit1.Top :=(-FTitleInfo.FrameRect.Top-ButtonedEdit1.Height) div 2+dy; ComboBox1.Top := ButtonedEdit1.Top; ComboBox2.Top := ButtonedEdit1.Top; Button1.Top := ButtonedEdit1.Top; Button1.Height := ButtonedEdit1.Height; // Генерация события OnResize inherited; end; procedure TFmMain.ComboBox1Change(Sender: TObject); begin FStyleChanging := (ComboBox1.ItemIndex=0) and TStyleManager.IsCustomStyleActive or (ComboBox1.ItemIndex<>0) and not TStyleManager.IsCustomStyleActive; if not FStyleChanging then exit; if ComboBox1.ItemIndex=0 then TStyleManager.TrySetStyle('Windows') else // TStyleManager.TrySetStyle('Windows10 Dark') ; TStyleManager.TrySetStyle('Carbon') ; end; procedure TFmMain.CheckWindowTheme; begin ComboBox1.ItemIndex := Ord(TFormTitleInfo.DarkModeIsEnabled); ComboBox1Change(nil); end; procedure TFmMain.WMSettingChange(var Message: TWMSettingChange); begin inherited; if FStyleChanging then exit; if Message.Section='ImmersiveColorSet' then CheckWindowTheme; 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; Resize; end; {$EndRegion} {$Region 'Обработчики Windows-сообщений'} procedure TFmMain.WMNCCalcSize(var Message: TWMNCCalcSize); var Params: PNCCalcSizeParams; M: TMonitor; R: TRect; begin if // Меняется стиль, ничего не вычисляем not FStyleChanging and (not FormIsDarkMode or Visible) and (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 R := TFormTitleInfo.GetTaskBarBounds; if not R.IsEmpty then if R.Width > R.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); var StyleChanged: Boolean; begin if HandleAllocated and DwmDefWindowProc(Handle, Message.Msg, Message.WParam, Message.LParam, Message.Result) then exit; StyleChanged := Message.Msg=CM_CUSTOMSTYLECHANGED; inherited; if StyleChanged then // if Message.Msg = CM_STYLECHANGED then DoStyleChange; 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. |
Скачать
Друзья, спасибо за внимание!
Исходник (zip) 138 Кб. Delphi XE 7
Исполняемый файл (zip) 1.07 Мб (Скомпилирован в XE 7)