Может кому-то пригодиться.
У меня сработало так ...
- Код: Выделить всё
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 высоты символа" доставляет
).
Ну ладно это костыль "не универсальный" так что пусть его . ( тем кто будет настраивать под себя или делать более надежно хоть будет понятно куда копать, а то догадаться что TControlCanvas в TGroupBox.WMPaint почему-то не работает можно только чудом )
Добавлено спустя 37 минут 28 секунд:
.
) 
