OwnerDraw TMenu

[Hyper]

Здравствуйте! Как сделать OwnerDraw Menu? Версия Lazarus: 1.6
Событий OnMeasureItem и OnDrawItem нет, в Google практически ничего не нашел по данному вопросу, только changelog Lazarus 1.8, где это реализовано.
Есть ли временное решение(любое, хоть готовый компонент) для собственной прорисовки меню? Спасибо.

[zub]

ЕМНИП в транке это есть. насколько работает - хз.

[Hyper]

Здравствуйте, zub! Спасибо за ответ! А что Вы можете сказать о CodeTyphon 5.8, базированной на Lazarus?
Скомпилировал её, у TMainMenu есть свойства OwnerDraw.

[zub]

Ничего хорошего - суррогат. Лучше один раз заморочиться и научиться ставить транк

[Снег Север]

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

[alexs]

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

У меня с ним сложилось противоположние впечатление.
Подтирать глюки, которые внесли эти горе сборщики - сомнительное удовольствие.
Проще работать с транком. И гораздо легче.

[pupsik]

Скомпилировал её, у TMainMenu есть свойства OwnerDraw.

оно есть и в транке лазаря. А вот работает ли и необходимо ли... х.з.

п.с.
по поводу "полезности" тифона.... Пробуйте.
Если что к Снег Север в личку. Походу у него одного одни приятные ощущения от его использования

Из замеченных багов:
1. Не всегда собирается скриптами.
2. Возможны баги при работе (последний у меня - только англ. фейс, предпоследний - не работали диалоги ("Пареметры проекта", "Настройки")).
3. Некоторые пакеты "узкие". Т.е. под определенную систему.
4. Бывают вылеты при работе.

Единственный плюс для меня - ORCA. Но..о она частично рабочая. Особенно её 3д часть. Хотя, возможно, в винде она адекватна.

[Hyper]

Собрал я, значит, Lazarus 1.7 из транков, однако OwnerDraw "порадовал", то ли я уже подзабыл, как это делается, либо недоработка компонента - меню закрашивается не до конца. Прикрепил скриншот и код. На скриншоте стрелкой указал область, где не закрашивается меню.

Код: Выделить всё

const
  DefaultHighLightColor = $00ED9564;  

procedure TMainForm.MainMenuDrawItem(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect; AState: TOwnerDrawState);
var
  MenuItem: TMenuItem;
begin
  MenuItem := Sender as TMenuItem;
  if (odSelected in AState) or (odHotLight in AState) then
  begin
    ACanvas.Font.Color := clWhite;
    ACanvas.Brush.Color := DefaultHighLightColor;
    ACanvas.FillRect(ARect);
    if not MenuItem.IsInMenuBar then
    begin
      if MenuItem.Caption <> '-' then
        ACanvas.TextOut(ARect.Left + 25, ARect.Top + 3, MenuItem.Caption);
    end
    else
    begin
      ACanvas.TextOut(ARect.Left + 9, ARect.Top + 2, MenuItem.Caption);
    end;
  end
  else
  begin
    ACanvas.Font.Color := clBlack;
    ACanvas.Brush.Color := clWhite;
    ACanvas.FillRect(ARect);
    if not MenuItem.IsInMenuBar then
    begin
      if MenuItem.Caption <> '-' then
        ACanvas.TextOut(ARect.Left + 25, ARect.Top + 3, MenuItem.Caption);
    end
    else
    begin
      ACanvas.TextOut(ARect.Left + 9, ARect.Top + 2, MenuItem.Caption);
    end;
  end;
  if MenuItem.Caption = '-' then
  begin
    ACanvas.Pen.Color := DefaultHighLightColor;
    ACanvas.Line(ARect.Left + 25, ARect.Top + 12, ARect.Right, ARect.Top + 12);
  end;
end;           

procedure TMainForm.MainMenuMeasureItem(Sender: TObject; ACanvas: TCanvas;
  var AWidth, AHeight: integer);
var
  MenuItem: TMenuItem;
begin
  ACanvas.FillRect(ACanvas.ClipRect);
  MenuItem := Sender as TMenuItem;
  if not MenuItem.IsInMenuBar then
  begin
    AWidth := aCanvas.TextWidth(MenuItem.Caption) + 25;
    AHeight := aCanvas.TextHeight(MenuItem.Caption) + 8;
  end
  else
  begin
    AWidth := aCanvas.TextWidth(MenuItem.Caption) + 3;
    AHeight := aCanvas.TextHeight(MenuItem.Caption) + 4;
  end;
end; 

 

[alexs]

Насколько я помню - эта область в винде уже не относится к меню. Там надо событие ловить виндовое на отрисовку не клиентской области.
Хотя могу и ошибаться.

[Hyper]

Долго искал решение и наконец-то! По запросу в Яндексe "MIM_BACKGROUND delphi" нашел код. Оставлю код здесь, может кому-нибудь пригодится.
Фон меню полностью закрасился в белый цвет, что и требовалось.

Код: Выделить всё

var
  MenuBarBackground: TBrush;
  MenuBarBackgroundOld: HBrush;  

procedure TMainForm.FormCreate(Sender: TObject);
var
  lpcmi: TMenuInfo;
begin
  MenuBarBackground:= TBrush.Create;
  MenuBarBackground.Color:= clWhite;  //Цвет фона - белый
  lpcmi.cbSize:= SizeOf(TMenuInfo);
  lpcmi.fMask:= MIM_BACKGROUND;
  GetMenuInfo(MainMenu.Handle, @lpcmi);
  MenuBarBackgroundOld:= lpcmi.hbrBack;
  lpcmi.fMask:= MIM_BACKGROUND or MIM_APPLYTOSUBMENUS;
  lpcmi.hbrBack:= MenuBarBackground.Handle;
  SetMenuInfo(MainMenu1.Handle, @lpcmi);
end; 

procedure TMainForm.FormDestroy(Sender: TObject);
var
  lpcmi: TMenuInfo;
begin
  ZeroMemory(@lpcmi, SizeOf(TMenuInfo));
  lpcmi.cbSize:= SizeOf(TMenuInfo);
  lpcmi.fMask:= MIM_BACKGROUND;
  lpcmi.hbrBack:= MenuBarBackgroundOld;
  SetMenuInfo(MainMenu1.Handle, @lpcmi);
  MenuBarBackground.Free;
end;  

[Alex2013]

У меня в Лазарусе 1.4.2 второй вариант вызвал эффект из разряда "мистического кода" ...
Ставлю в начале FormCreate меню просто исчезает ставлю после всех моих инициализаций ничего не делает.
(Возможно из Аэро и Вин 7 ? )
Ps
Добавил в конце DrawMenuBar(Handle);

Получилось вот что (вместо "радикально красного меню" красная рамка ) :

А это режим совместимости с XP...

То есть нужно применять оба метода вместе ?
Ps.Ps.

Кстати для компиляция этой заплатки нужно подключить в Uses модуль Windows причем первым ...

[Hyper]

Приветствую, Alex2013!
Да, нужно применять оба метода вместе - первый метод прорисовывает непосредственно меню и его пункты, а второй код - заливает белым цветом оставшуюся полоску меню (которая в моем скриншоте выше - серая).

У компонента TMainMenu в свойствах должно быть проставлено OwnerDraw = true, это свойство есть в компоненте, начиная с Lazarus 1.7, у Вас версия 1.4.2

(Возможно из Аэро и Вин 7 ? )

Нет, у меня на Windows 7 с включенным Aero всё нормально, на Windows 10 тоже все работает.
Версия Lazarus 1.4.2, скорее всего, не позволит реализовать корректно. Последняя версия Lazarus 1.6, моя версия Lazarus 1.7 собрана из транков.

OnDrawItem и OnMeasureItem находятся на вкладке "События" в TMainMenu, проверьте, есть ли такие свойства в Вашем Lazarus.

P.S. Если Вам понадобится Lazarus 1.7, пишите мне в ЛС, я могу отправить сборку.

[Лекс Айрин]

Hyper, проще дать SVN svn co http://svn.freepascal.org/svn/lazarus/trunk ./new (я сначала кидаю в отдельную папку, а потом раскидываю по компам, поэтому такая странная папка получатель).

[Hyper]

Hyper, проще дать SVN svn co http://svn.freepascal.org/svn/lazarus/trunk ./new (я сначала кидаю в отдельную папку, а потом раскидываю по компам, поэтому такая странная папка получатель).

Здравствуйте! Еще можно дать инструкцию, как собрать Lazarus
http://wiki.freepascal.org/Installing_L ... 28Win32.29

[Лекс Айрин]

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

ЗЫ: давать англоязычный вариант, если есть русский как-то странновато.

Кстати, иногда, по крайней мере в винде, выравнивают один пункт меню по правой стороне (справку). Если удастся подобное, то проблема исчезнет сама собой.