From 71e9292885a845ac3a739953ca46d599dc374295 Mon Sep 17 00:00:00 2001 From: 4aiman Date: Fri, 21 Aug 2026 10:44:31 +0300 Subject: [PATCH] =?UTF-8?q?=D0=9F=D0=BE=D0=BB=D0=BE=D1=81=D0=B0=20=D0=BC?= =?UTF-8?q?=D0=B5=D0=BD=D1=8E=20=D1=81=D0=BD=D0=BE=D0=B2=D0=B0=20=D0=BD?= =?UTF-8?q?=D0=B0=D1=81=D1=82=D0=BE=D1=8F=D1=89=D0=B0=D1=8F,=20=D1=86?= =?UTF-8?q?=D0=B2=D0=B5=D1=82=20=D0=B7=D0=B0=D0=B4=D0=B0=D1=91=D1=82=D1=81?= =?UTF-8?q?=D1=8F=20=D0=BF=D0=BE-=D1=81=D0=B2=D0=BE=D0=B5=D0=BC=D1=83=20?= =?UTF-8?q?=D0=BD=D0=B0=20=D0=BA=D0=B0=D0=B6=D0=B4=D0=BE=D0=B9=20=D1=81?= =?UTF-8?q?=D0=B8=D1=81=D1=82=D0=B5=D0=BC=D0=B5?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Самодельная полоса из кнопок стоила поведения: наведение на соседнее название не перекидывало туда раскрытый список, не работал переход по меню с Alt и стрелками. Подражать настоящему меню своими руками пришлось бы до бесконечности, а причина отказа была одна — цвет. Цвет решается иначе. Под gtk2 своими руками меню не рисуется, и это записано в самом LCL: OwnerDraw, OnDrawItem и OnMeasureItem там помечены как неподдерживаемые (interfaces/gtk2/issues.xml), вызывает DoDrawItem только win32. Зато gtk принимает описание стиля текстом — gtk_rc_parse_string, разбирается один раз до создания окон. Под win32 наоборот: строк стиля нет, зато отрисовка пунктов работает, в том числе для названий в самой полосе. Проверено отдельным пробником (probe/menu): настоящее TMainMenu под gtk2 берёт наши цвета и в полосе, и в раскрытом списке, включая цвет выделенного пункта. Отрисовка пунктов теперь отличает полосу от раскрытого списка: в полосе не нужно место под галочку и сочетание клавиш, иначе название разошлось бы с шириной, которую мы же и посчитали. Остаток полосы правее последнего названия под Windows по-прежнему рисует система — это уступка, а не решение. --- .gitignore | 5 ++ nlve.lpr | 3 ++ src/uMainForm.lfm | 9 ---- src/uMainForm.pas | 123 +++++++++------------------------------------- src/uTheme.pas | 83 +++++++++++++++++++++++++++++-- 5 files changed, 110 insertions(+), 113 deletions(-) diff --git a/.gitignore b/.gitignore index e60625a..789c22c 100644 --- a/.gitignore +++ b/.gitignore @@ -42,3 +42,8 @@ shot*.png # Журнал последнего запуска /nlve.log + +# Сборка пробников. Сами исходники нужны: они и есть запись замера. +/probe/*/units/ +/probe/menu/menuprobe +/probe/menu/menuprobe.exe diff --git a/nlve.lpr b/nlve.lpr index a03aaab..abec454 100644 --- a/nlve.lpr +++ b/nlve.lpr @@ -18,6 +18,9 @@ begin Application.Title := 'nlve'; Application.Scaled := True; Application.Initialize; + { Цвета меню задаются до создания окон: под gtk2 это строка стиля, а её + разбирают один раз — уже созданные виджеты о ней не узнают. } + ApplyMenuStyle; { Подписка на появление окон: своим окнам цвета задаются в их же обработчике создания, а это подстраховка на случай окна, созданного самой библиотекой. } diff --git a/src/uMainForm.lfm b/src/uMainForm.lfm index 39475e5..857c099 100644 --- a/src/uMainForm.lfm +++ b/src/uMainForm.lfm @@ -13,15 +13,6 @@ object MainForm: TMainForm OnKeyDown = FormKeyDown OnShow = FormShow LCLVersion = '4.6' - object pnlMenu: TPanel - Left = 0 - Height = 26 - Top = 0 - Width = 1600 - Align = alTop - BevelOuter = bvNone - TabOrder = 4 - end object memoLog: TLogView Left = 0 Height = 130 diff --git a/src/uMainForm.pas b/src/uMainForm.pas index dd00ad4..37a675c 100644 --- a/src/uMainForm.pas +++ b/src/uMainForm.pas @@ -47,7 +47,6 @@ type OpenMediaDialog: TOpenDialog; OpenProjectDialog: TOpenDialog; pnlBottom: TPanel; - pnlMenu: TPanel; pnlLeft: TPanel; pnlMain: TPanel; pnlTimelineHost: TPanel; @@ -87,10 +86,7 @@ type FLogFilePath: string; FLogFileStarted: Boolean; FLogFileBroken: Boolean; - { Списки полосы меню. Хранятся, чтобы искать по ним сочетания клавиш: - системной полосы меню нет, и форма сама их не найдёт. } - FMenus: TFPList; - FMenuX: Integer; + FMenu: TMainMenu; { Отложенный показ списка меню. Номер списка и точка, где его раскрыть; таймер срабатывает один раз. } { Показ фоновой работы. Пока что-то считается в стороне от окна, @@ -98,9 +94,6 @@ type FJobLabel: TLabel; FJobBar: TThemedProgress; FJobTimer: TTimer; - FMenuPending: Integer; - FMenuPendingAt: TPoint; - FMenuTimer: TTimer; { Уплощённый монтаж, отданный плееру. Хранится, чтобы по времени находить звучащий кусок и брать у него громкость. } FPreviewSegments: TFlatSegmentArray; @@ -188,11 +181,8 @@ type { --- окно и меню --- } procedure BuildMenu; - procedure MenuBarClick(Sender: TObject); - procedure MenuTimerTick(Sender: TObject); procedure BuildJobIndicator; procedure JobTimerTick(Sender: TObject); - procedure FormShortCut(var Msg: TLMKey; var Handled: Boolean); procedure BuildTimeline; procedure StartPlayer; procedure Log(const AText: string); @@ -403,7 +393,6 @@ begin FreeAndNil(FProject); { Сами списки принадлежат форме и уничтожатся с ней; здесь только перечень ссылок на них. } - FreeAndNil(FMenus); end; procedure TMainForm.ApplySettings; @@ -481,39 +470,26 @@ end; { Меню строится кодом: в файле формы оно заняло бы сотню строк описания вложенных пунктов, где легко ошибиться и трудно что-то найти. - Полоса меню тоже своя, из обычных кнопок, а не системная. Причина одна: - системную полосу рисует Windows, и её светлый фон нашим цветом не - закрашивается — SetMenuInfo меняет подложку пунктов, но не саму полосу. - Сочетания клавиш от этого не теряются: их ищет TMenu.IsShortCut, и - вызвать его можно самим, что и делает FormShortCut. + Полоса меню — настоящая, TMainMenu. - Ценой отказа от системной полосы становится переход по меню клавишей - Alt — его больше нет. Сочетания клавиш работают все. } + Некоторое время она была своя, из обычных кнопок: под Windows системную + полосу нашим цветом не закрасить, SetMenuInfo меняет подложку пунктов, но + не саму полосу. Цена оказалась велика, и вся она в поведении: наведение + на соседнее название не перекидывало на него раскрытый список, не + работал переход по меню с Alt и стрелками. Подражать настоящему меню + своими руками пришлось бы до бесконечности. + + Цвет решается иначе, на каждой системе своим способом: под gtk2 строкой + стиля (ApplyMenuStyle), под win32 отрисовкой пунктов своими руками + (ApplyDarkMenu). Остаток полосы правее последнего названия под Windows + по-прежнему рисует система — это известная и принятая уступка. } procedure TMainForm.BuildMenu; function AddTop(const ACaption: string): TMenuItem; - var - Popup: TPopupMenu; - Btn: TThemedButton; - W: Integer; begin - Popup := TPopupMenu.Create(Self); - FMenus.Add(Popup); - - Btn := TThemedButton.Create(Self); - Btn.Parent := pnlMenu; - W := pnlMenu.Canvas.TextWidth(ACaption) + 24; - Btn.SetBounds(FMenuX, 0, W, pnlMenu.ClientHeight); - Btn.Caption := ACaption; - { Фокус кнопкам меню не нужен: по ним щёлкают, а обходить их клавишей - Tab при работе с монтажом только мешает. } - Btn.TabStop := False; - Btn.Flat := True; - Btn.Tag := FMenus.Count - 1; - Btn.OnClick := @MenuBarClick; - Inc(FMenuX, W); - - Result := Popup.Items; + Result := TMenuItem.Create(Self); + Result.Caption := ACaption; + FMenu.Items.Add(Result); end; procedure AddItem(AParent: TMenuItem; const ACaption: string; @@ -541,14 +517,7 @@ var MFile, MEdit, MView, MProject: TMenuItem; begin BuildJobIndicator; - FMenus := TFPList.Create; - FMenuX := 4; - FMenuPending := -1; - FMenuTimer := TTimer.Create(Self); - FMenuTimer.Enabled := False; - FMenuTimer.Interval := 1; - FMenuTimer.OnTimer := @MenuTimerTick; - OnShortCut := @FormShortCut; + FMenu := TMainMenu.Create(Self); MFile := AddTop('Файл'); AddItem(MFile, 'Новый проект', @MenuNewProject, ShortCut(VK_N, [ssCtrl])); @@ -602,6 +571,11 @@ begin AddSep(MProject); AddItem(MProject, 'Добавить дорожку', @MenuAddTrack); AddItem(MProject, 'Удалить последнюю дорожку', @MenuRemoveTrack); + + { Цвета назначаются до того, как меню отдано окну: под win32 обработчики + отрисовки должны быть на месте к первому показу. } + ApplyDarkMenu(FMenu); + Menu := FMenu; end; { Показ фоновой работы. @@ -698,59 +672,6 @@ begin end; end; -{ Щелчок по названию в полосе меню раскрывает соответствующий список. - - Сам показ откладывается на один оборот очереди сообщений. - - Причина замерена. Пока идёт обработка щелчка, указатель захвачен - кнопкой, и раскрытому списку захват уже не достаётся. Внешне это - выглядело так, что меню открывается через раз: первый щелчок 175 мс, - второй не открывает вовсе, третий снова 175 мс. Попытка открывать по - нажатию, как это делают настоящие полосы меню, под gtk2 не открывает - список ни разу — захват там держится ещё крепче. - - Таймер отпускает обработчик, захват снимается, и список открывается - каждый раз. } -procedure TMainForm.MenuBarClick(Sender: TObject); -var - Btn: TThemedButton; -begin - Btn := Sender as TThemedButton; - if (Btn.Tag < 0) or (Btn.Tag >= FMenus.Count) then - Exit; - FMenuPending := Btn.Tag; - FMenuPendingAt := Btn.ClientToScreen(Point(0, Btn.Height)); - FMenuTimer.Enabled := False; - FMenuTimer.Enabled := True; -end; - -procedure TMainForm.MenuTimerTick(Sender: TObject); -var - Popup: TPopupMenu; -begin - FMenuTimer.Enabled := False; - if (FMenuPending < 0) or (FMenuPending >= FMenus.Count) then - Exit; - Popup := TPopupMenu(FMenus[FMenuPending]); - FMenuPending := -1; - ApplyDarkMenu(Popup); - Popup.PopUp(FMenuPendingAt.X, FMenuPendingAt.Y); -end; - -{ Сочетания клавиш ищем сами: системной полосы меню больше нет, а значит - форма их сама не найдёт. } -procedure TMainForm.FormShortCut(var Msg: TLMKey; var Handled: Boolean); -var - I: Integer; -begin - for I := 0 to FMenus.Count - 1 do - if TPopupMenu(FMenus[I]).IsShortCut(Msg) then - begin - Handled := True; - Exit; - end; -end; - procedure TMainForm.FormShow(Sender: TObject); var I: Integer; diff --git a/src/uTheme.pas b/src/uTheme.pas index f00c857..f8dcd88 100644 --- a/src/uTheme.pas +++ b/src/uTheme.pas @@ -18,8 +18,10 @@ - полосы прокрутки внутри списков и журнала рисует система; - рамка окна и её кнопки принадлежат оконному менеджеру; - меню под gtk2 своими руками не рисуется — в LCL это прямо помечено - как неподдерживаемое (interfaces/gtk2/issues.xml). Под Windows - рисуется, там это и нужно. + как неподдерживаемое (interfaces/gtk2/issues.xml). Зато сам gtk + принимает описание стиля текстом, и цвет меню задаётся так + (ApplyMenuStyle). Под Windows наоборот: строк стиля нет, зато + работает отрисовка пунктов своими руками (ApplyDarkMenu). } unit uTheme; @@ -151,9 +153,25 @@ procedure ApplyDarkTheme(AComponent: TComponent); при запуске. } procedure HookNewForms; -{ Меню в наших цветах. Под gtk2 не действует — там меню рисует GTK. } +{ Меню в наших цветах отрисовкой своими руками. Действует только под + win32; под gtk2 цвет задаётся строкой стиля, см. ApplyMenuStyle. } procedure ApplyDarkMenu(AMenu: TMenu); +{ Цвета для меню, которое рисует не программа, а система. + + Вызывать до создания окон: строка стиля разбирается один раз, и уже + созданные виджеты о ней не узнают. + + Под gtk2 это единственный способ. Собственных средств у LCL там нет — + OwnerDraw, OnDrawItem и OnMeasureItem в gtk2 прямо помечены как + неподдерживаемые (lcl/interfaces/gtk2/issues.xml), и событие из + инспектора объектов просто никогда не наступит. Зато сам gtk принимает + описание стиля текстом. + + Под win32 ничего не делает: там работает отрисовка своими руками через + ApplyDarkMenu. } +procedure ApplyMenuStyle; + { Окно сообщения в наших цветах вместо системного. Кнопки задаются готовым набором, как у MessageDlg, но рисуются нашими. @@ -164,6 +182,11 @@ function ThemedMessageDlg(const ACaption, AText: string; implementation +{$IFDEF LCLGTK2} +uses + glib2, gtk2; +{$ENDIF} + {$IFDEF WINDOWS} { Модуль Windows целиком подключать нельзя: он объявляет свои TRect и RegisterClass, а имена в Паскале нечувствительны к регистру — и обычные @@ -213,6 +236,7 @@ const MenuTextLeft = 26; { отступ слева: место под галочку } MenuTextRight = 16; { отступ справа: место под стрелку подменю } MenuGap = 28; { просвет между названием и сочетанием клавиш } + MenuBarSide = 10; { отступ по краям названия в полосе меню } { TThemedProgress } @@ -567,6 +591,15 @@ begin H := ACanvas.TextHeight('Wg'); Y := ARect.Top + (ARect.Bottom - ARect.Top - H) div 2; + { В полосе меню отступ слева другой: место под галочку и под сочетание + клавиш там не нужно, а с отступом раскрытого списка названия разошлись + бы с шириной, которую мы же и посчитали. } + if Item.IsInMenuBar then + begin + ACanvas.TextOut(ARect.Left + MenuBarSide, Y, Item.Caption); + Exit; + end; + if Item.Checked then ACanvas.TextOut(ARect.Left + 8, Y, '•'); @@ -599,6 +632,13 @@ begin end; AHeight := ACanvas.TextHeight('Wg') + 10; + + if Item.IsInMenuBar then + begin + AWidth := ACanvas.TextWidth(Item.Caption) + MenuBarSide * 2; + Exit; + end; + W := MenuTextLeft + ACanvas.TextWidth(Item.Caption) + MenuTextRight; if Item.ShortCut <> 0 then Inc(W, MenuGap + ACanvas.TextWidth(ShortCutToText(Item.ShortCut))); @@ -772,6 +812,43 @@ begin ApplyToChildren(TWinControl(AControl)); end; +{ Цвет Паскаля хранит составляющие в обратном порядке, а gtk ждёт + привычную запись «решётка, красный, зелёный, синий». } +function GtkColorText(AColor: TColor): string; +begin + Result := Format('#%.2x%.2x%.2x', + [AColor and $FF, (AColor shr 8) and $FF, (AColor shr 16) and $FF]); +end; + +procedure ApplyMenuStyle; +{$IFDEF LCLGTK2} +var + Rc: string; +{$ENDIF} +begin +{$IFDEF LCLGTK2} + Rc := + 'style "nlve-menu" {' + LineEnding + + ' bg[NORMAL] = "' + GtkColorText(ThemePanel) + '"' + LineEnding + + ' bg[PRELIGHT] = "' + GtkColorText(ThemeAccent) + '"' + LineEnding + + ' bg[ACTIVE] = "' + GtkColorText(ThemePanel) + '"' + LineEnding + + ' bg[INSENSITIVE] = "' + GtkColorText(ThemePanel) + '"' + LineEnding + + ' fg[NORMAL] = "' + GtkColorText(ThemeText) + '"' + LineEnding + + ' fg[PRELIGHT] = "' + GtkColorText(ThemeAccentText) + '"' + LineEnding + + ' fg[ACTIVE] = "' + GtkColorText(ThemeText) + '"' + LineEnding + + ' fg[INSENSITIVE] = "' + GtkColorText(ThemeTextDim) + '"' + LineEnding + + ' text[NORMAL] = "' + GtkColorText(ThemeText) + '"' + LineEnding + + ' base[NORMAL] = "' + GtkColorText(ThemePanel) + '"' + LineEnding + + '}' + LineEnding + + 'class "GtkMenuBar" style "nlve-menu"' + LineEnding + + 'class "GtkMenu" style "nlve-menu"' + LineEnding + + 'class "GtkMenuItem" style "nlve-menu"' + LineEnding + + 'widget_class "**" style "nlve-menu"' + LineEnding + + 'widget_class "**" style "nlve-menu"' + LineEnding; + gtk_rc_parse_string(PChar(Rc)); +{$ENDIF} +end; + procedure ApplyDarkMenu(AMenu: TMenu); procedure Walk(AItem: TMenuItem);