PageControl изменить стиль заголовка TabSheet

Вопросы программирования и использования среды Lazarus.

Модератор: Модераторы

Re: PageControl изменить стиль заголовка TabSheet

Сообщение amateur » 04.09.2013 21:01:48

1.
не лава а ORCE
склонил не так и че из этого ... ? Хотя, судя по бурным поискам правильно склонил :wink:

2. ORCA (ранее Lava) самостоятельно занимается отрисовкой компонентов. Кажись у них все стандартные реализованы. Есть баги. Но, в принципе, нормальная вещица. Свой компонент "впихнуть" сложновато.

3. ORCA не тестил, а вот лава (по крайней мере в gtk) работала не хуже чем в винде. Только надо парочку devов установить.

Но есть что-то существенное что подправили в тифоне, а в лазаре нет. Поэтому наблюдаются "странности".

Есть 2Д и 3Д вариации. В зависимости от потребности :).
Аватара пользователя
amateur
энтузиаст
 
Сообщения: 552
Зарегистрирован: 03.08.2007 10:15:32

Re: PageControl изменить стиль заголовка TabSheet

Сообщение Alex2013 » 05.09.2022 13:19:20

Может кому-то пригодиться.
У меня сработало так ...
Код: Выделить всё
type

TPageControl = class(ComCtrls.TPageControl)
  private
    procedure CNDrawItem(var Message: TWMDrawItem); message WM_DRAWITEM;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  end;
....
implementation
...
procedure TPageControl.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    if not (csDesigning in ComponentState) then
      Style := Style or TCS_OWNERDRAWFIXED;
  end;
end;
   function UTF8_CP1251(const s: string): string;far;
var RS:String;
begin
//msg('1>'+S);
RS:=S;
//RS:= UTF8TOCP1251 (S,true);
coder.UTF8ToWindows1251(RS);
Result:=RS;
end;
function UTF8_CP866(const s: string): string;far;
var RS:String;
begin
//msg('1>'+S);
RS:=S;
//RS:= UTF8TOCP1251 (S,true);
coder.OEM866ToWindows1251(RS);
//Windows866toWindows1251(RS);
coder.UTF8ToWindows1251(RS);
Result:=RS;
end;

procedure TPageControl.CNDrawItem(var Message: TWMDrawItem);
var
  BrushHandle: HBRUSH;
  BrushColor: COLORREF;
begin
  with Message.DrawItemStruct^ do
  begin
    case itemID of
      0: BrushColor := RGB(235, 24, 33);
      1: BrushColor := RGB(247, 200, 34);
      2: BrushColor := RGB(178, 229, 26);
      3: BrushColor := RGB(178, 26, 229);
    else
      BrushColor := ColorToRGB(clBtnFace);
    end;
    BrushHandle := CreateSolidBrush(BrushColor);
    FillRect(hDC, rcItem, BrushHandle);
// hDC:=FProgSetting.Canvas.Handle;
    SetBkMode(hDC, TRANSPARENT);
    DrawTextEx(hDC, PChar(UTF8_CP1251(Page[itemID].Caption)), -1, rcItem, DT_CENTER or
      DT_VCENTER or DT_SINGLELINE, nil);
  end;
  Message.Result := 1;
end;


Но это еще не все !
Что-бы изменить фон самой страницы табконтрол нужно "пропатчить" .
Код: Выделить всё
Uses  UxTheme....
...
procedure FixPageControl(ACtrl: TObject);
// Turns Themes off for TPageControl
var
  I: Integer;
begin
  if ACtrl is TPageControl then begin
    UxTheme.SetWindowTheme(TPageControl(ACtrl).Handle, NIL, 'Cyber');
  end;
end;

procedure TFrom1.FormCreate(Sender: TObject);
begin
   FixPageControl( PageControl1 );
//Меняю основной цвет формы (Без этого "пустые станицы"  не меняют цвет)
  Color:=$383838;
  Font.Color:=clSilver;
//А теперь так ...
   TabSheet1.Color:=$383838;
   TabSheet1.Font.Color:=clSilver;
 
   TabSheet2.Color:=$484848;
   TabSheet2.Font.Color:=clSilver;

   TabSheet3.Color:=$585858;
   TabSheet3.Font.Color:=clSilver;
   
  TabSheet4.Color:=$686868;
  TabSheet4.Font.Color:=clSilver;
...

end;
 

Получилось довольно симпатично (я в курсе что это "кислотные цвета" но это просто для теста )
Изображение

Но внезапно вылезла новая проблема ... не меняются цвета подсказки CheckBox и GroupBox.
Зы
Да еще кто знает как заставить DrawTextEx работать с UTF8 ?
( Выкрутился прикрутив конверсию UTF8_CP1251 но как то это криво )

Добавлено спустя 21 час 39 минут 46 секунд:
Еще немного "танцев с бубном " теперь с TCheckBox.
Код: Выделить всё
type
  TCheckBox = class(StdCtrls.TCheckBox)
  private
    procedure WMErase(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMPaint (var Message: TWMPaint); message WM_PAINT;
  end;

procedure TCheckBox.WMErase(var Message: TWMEraseBkgnd);
var
  canv: TControlCanvas;
begin
  canv := TControlCanvas.Create;
  canv.Control := Self;
  canv.Brush.Color := Self.Color;
  canv.FillRect(canv.ClipRect);
  canv.free;
end;

procedure TCheckBox.WMPaint(var Message: TWMPaint);
const
  SPACE: Integer = 2;
var
  txtW, txtH, txtX, BtnWidth: Integer;
  canv: TControlCanvas;
begin

  inherited;
  BtnWidth := GetSystemMetrics(SM_CXMENUCHECK);
  canv := TControlCanvas.Create;
  try
    canv.Control := Self;
    canv.Font := Font;
    txtW:= canv.TextWidth(Caption);
    txtH:= canv.TextHeight(Caption);
    if BiDiMode in [bdRightToLeft, bdRightToLeftReadingOnly] then
      txtX:= Width - BtnWidth - SPACE - txtW
    else
      txtX:= BtnWidth + SPACE;
      canv.Brush.Color := Self.Color;
      canv.TextOut(txtX,(Height - txtH) div 2 + 1, Caption);
  finally
    canv.Free;
  end;
end;

Ужос !
Вот чем нужно было думать чтобы написать тупейшую отрисовку с невозможностью поменять цвет ?
( Причем как я понимаю в Дельфи тоже самое )

Добавлено спустя 19 часов 47 минут 22 секунды:
"Еще четыреста ведер воды..." и TGroupBox тоже заработал как надо .
Код: Выделить всё
  TGroupBox = class(StdCtrls.TGroupBox)
     public
       procedure WMPaint (var Message: TWMPaint); message WM_PAINT;
   end;
//...
procedure TGroupBox.WMPaint(var Message: TWMPaint);
var
  H: Integer;
  canv: TCanvas;
  begin
inherited;
  canv := TCanvas.Create;
  canv.Handle:= Message.DC;
  canv.Font := Self.Font;
  canv.Font.Color :=  Self.Font.Color;
   H := canv.TextHeight('0');
  SetBkMode(canv.Handle, TRANSPARENT);
  canv.TextOut(7,-Trunc(h*1.2),self.Caption);
  canv.free;
end;

Но черт подери ! Сколько километров неров мне это выело. (Это сейчас код кроткий, а вначале там была целая "простынь кода" ) И то через какие-то загадочные циферки.. ( особенно "-1.2 высоты символа" доставляет :mrgreen: ).
Ну ладно это костыль "не универсальный" так что пусть его . ( тем кто будет настраивать под себя или делать более надежно хоть будет понятно куда копать, а то догадаться что TControlCanvas в TGroupBox.WMPaint почему-то не работает можно только чудом ) :roll:

Добавлено спустя 37 минут 28 секунд:
Изображение
Последний раз редактировалось Alex2013 28.09.2022 10:06:12, всего редактировалось 1 раз.
Alex2013
долгожитель
 
Сообщения: 2923
Зарегистрирован: 03.04.2013 11:59:44

Re: PageControl изменить стиль заголовка TabSheet

Сообщение Sharfik » 07.09.2022 20:11:06

За такое надо кактусами турецкими бить. :?
1. Дизайн "вырви глаз".
2. Есть люди имеющие ограничения по зрению. И одна из статей на ХабрХабре была этому посвящена. Не случайно у ОС есть отдельные контрастные режимы. Поэтому любые изменения цвета от стандартного в ОС - зло! Хватит издеваться над пользователями. И так больные наголову GUI дизайнеры уже доигрались превратив ПО в черти что. Кнопки на ощупь уже искать приходится.
Аватара пользователя
Sharfik
энтузиаст
 
Сообщения: 759
Зарегистрирован: 20.07.2013 01:04:30

Re: PageControl изменить стиль заголовка TabSheet

Сообщение Alex2013 » 07.09.2022 23:52:58

1 Совершенно согласен( "кислота плавиковая" ), но это просто для тестирования.(уже писал кстати )

2 Нормальной программе должно быть несколько готовых тем оформления + взятые из настроек ОС и самое главное полная настройка поллитры "под себя".
(То есть примерно так как это сделано в IDE Лазаруса)

Что касается того на что лично я равняюсь в этой ветке моего проекта, то это интерфейс программы FS Клиент .
( Там цвета берутся напрямую из "системных настроек" ОС Виндовс 10 - все простенько но со вкусом )

Предыдущая версия "проекта Лесхоз" была тестом функционала и интерфейс там рос "как сорняки".
А взявшись за рефакторинг я решил сделать все как можно ближе к уже давно привычному интерфейсу "FS Клиента" . ( Кстати весьма возможно, что все эти ухищрения с PageControl так и не пригодятся в условном "релизе", но пока что окно настроек "цельно утянуто" из совсем другого подхода к написанию интерфейса отсюда и полезли проблемы :idea: )

Было ...

Изображение


Будет (Кроме ядовито красной полосы сверху (это из настроек винды ) )...

Изображение
Последний раз редактировалось Alex2013 28.09.2022 10:09:30, всего редактировалось 1 раз.
Alex2013
долгожитель
 
Сообщения: 2923
Зарегистрирован: 03.04.2013 11:59:44

Re: PageControl изменить стиль заголовка TabSheet

Сообщение Alex2013 » 25.09.2022 11:55:22

Для тех кого волновала "едкая кислота" в цветном варианте PageControl сообщаю: это вполне поправимо .
Изображение

Код: Выделить всё
procedure TPageControl.CNDrawItem(var Message: TWMDrawItem);
var
  BrushHandle: HBRUSH;
  BrushColor: COLORREF;
begin
  with Message.DrawItemStruct^ do
  begin
    BrushColor :=$383838;
  if  itemID= self.ActivePageIndex then
     BrushColor := RGB(225, 24, 33);
 
    BrushHandle := CreateSolidBrush(BrushColor);
    FillRect(hDC, rcItem, BrushHandle);
    SetBkMode(hDC, TRANSPARENT);
    Windows.SetTextColor(hDC,clWhite );
    DrawTextEx(hDC, PChar(UTF8_CP1251(Page[itemID].Caption)), -1, rcItem, DT_CENTER or
      DT_VCENTER or DT_SINGLELINE, nil);
  end;
  Message.Result := 1;
end;



Все работает, только не забывайте делать рефреш при смене страницы ( по соответствующему событию PageControl ).
Код: Выделить всё
procedure TForm1.PageControl1Change(Sender: TObject);
begin
refresh;
end;
Alex2013
долгожитель
 
Сообщения: 2923
Зарегистрирован: 03.04.2013 11:59:44

Re: PageControl изменить стиль заголовка TabSheet

Сообщение Alex2013 » 01.10.2022 21:18:57

Кстати если кому-то нужен цветной скроллбар то с ним "все сложно" ( сделать так это делают в дельфи не получается ) но есть готовое решение в пакете Graphics32 Base ( TGaugeBar или TRangeBar )
Зы
В Делфи это делают так
type
TColorScrollBar=class(TScrollBar)
privae
procedure CNCtlColorScrollBar(var Msg:TMessage);message CN_CtlColorScrollBar;
published
property Color;
end;

procedure TColorScrollBar.CNCtlColorScrollBar(var Msg:TMessage);
begin
DefaultHandler(Msg)
end;
но в Лазарусе это почему то не сработало.
Alex2013
долгожитель
 
Сообщения: 2923
Зарегистрирован: 03.04.2013 11:59:44

Пред.

Вернуться в Lazarus

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 33

Рейтинг@Mail.ru