Наследники TStyleHook служат для перехвата событий и пользовательской отрисовки компонента. Что позволяет кардинально улучшить интерфейс без написания своих компонент и хакерских уловок. Планировал к стилям зайти издалека, но уж так как-то само собой сложилось, что буду описывать сейчас.
Небольшое вступление
Буквально несколько слов. Я против стремления писать для конкретного проекта универсальный код. Это отнимает много времени, неоправданно затягивает проект, и ни к чему хорошему не приводит. Невозможно учесть все, тем более нельзя предсказать, что появится в будущем. Более того, вернувшись к проекту через полгода-год, хочется все переписать. То, что казалось мега-крутым, на поверку оказалось ненужным.
Я также против неуемного желания использовать сторонние супер-компоненты. Есть конкретный проект, в нем есть конкретные проблемы. Вот их и надо решать. Если их можно решить без сторонних компонент, зачем они нужны?
В Delphi есть возможность подключить тему из предложенного списка. Тема хороша тем, что ее внешний вид не зависит от ОС и можно использовать хуки стилей. Плоха тем, что включаются небольшие, но тормоза. Однако, если не задаваться целью менять темы на ходу, а выбрать какую-то одну и творить в ее рамках, с помощью TStyleHook можно очень легко и очень быстро менять вид и поведение стандартных компонент.
Жаль, что при стандартной теме Windows такой фокус со TStyleHook не проходит.
Выбрал тему Light. Потому что минималистична, имеет малый размер и белая. Последнее очень субъективно, согласен.
Мерцание области отрисовки
После выбора темы, снова начались проблемы с «морганием» отрисовки при изменении размеров окна и масштабировании. Это как раз те самые тормоза, о которых шла речь выше, плюс начинают работать уже зарегистрированные стили. Ранее, проблема была решена так. Сейчас сделаем это через хук.
Для ScrollBox’а уже есть свой хук — TScrollBoxStyleHook. Сделаем наследника от него.
|
1 2 3 |
TScrollBoxStyleHookEx = class (TScrollBoxStyleHook) procedure PaintBackground(Canvas: TCanvas); override; end; |
Иными словами, все устраивает, кроме отрисовки фона. Реализация переопределенного метода удивляет лаконичностью:
|
1 2 3 4 5 |
procedure TScrollBoxStyleHookEx.PaintBackground(Canvas: TCanvas); begin if not (csCustomPaint in Control.ControlState) then inherited; end; |
То есть не делать вообще ничего в том случае, если во множестве ControlState компонента присутствует csCustomPaint.
Так как это хук конкретно для ScrollBox’а, у которого по умолчанию csCustomPaint отсутствует, добавим его в пару интересующих нас ScrollBox’ов. Делаем это как обычно в событии OnCreate формы.
|
1 2 |
sbxLeft.ControlState := sbxLeft.ControlState + [csCustomPaint]; sbxRight.ControlState := sbxRight.ControlState + [csCustomPaint]; |
В предыдущей статье описано, что PaintBox’ы имеют размер либо больше, либо равный клиентской части родителя. Поэтому перерисовывать фон не требуется. Мерцание возникает именно из-за того, что вначале рисуется фон, потом поверх него битмап. DoubleBuffered тут не поможет.
Регистрируем стиль:
|
1 |
TCustomStyleEngine.RegisterStyleHook(TScrollBox, TScrollBoxStyleHookEx); |
И наслаждаемся плавностью отрисовки. Хук конечно использован не по назначению, но между тем одной проблемой меньше.
Мы решаем конкретные проблемы конкретного проекта.
Шрифт из ресурса
В предыдущей статье описана проблема с кракозяблами под Windows 7. Связана проблема с бедностью юникода и шрифта на тот момент.
Вместо пиктограмм на BitBtn использую символы юникода и шрифт Segoe UI Symbol. Удобно менять цвет при наведении, сделать тень под символом и прочие эффекты. Шрифт был создан специально для Windows 7. На момент создания юникод еще не был столь красочным, как сейчас. Понятно, что нужно как-то подсунуть приложению шрифт от Windows 10, который весит 2.34 Мбайт вместо 504 Кбайт от семерки.
Будем делать через подключение ресурса со шрифтом. И, да, размер исполняемого файла увеличится на 2.34 метра. Повторю для одного упертого оппонента — это не тема, а шрифт увеличивает размер файла. Без ресурса — 2.97 Мб, с ресурсом 5.31 Мб. С темой размер становится 5.39 Мб. Тема дает мизерный прирост.
Сделать файл RES
Делать будем по старинке. Создадим каталог Fonts, поместим в него файл шрифта seguisym.ttf. Создадим текстовый файл с расширением .rc — Fonts.rc. В нем пишем такую строку:
|
1 |
IP_FONT N2 "seguisym.ttf" |
Создадим файл tores.cmd в котором пишем:
|
1 |
BRCC32.exe Fonts.rc |
Запускаем, получаем файл Fonts.res. Файл ресурсов готов.
Подключить и получить ресурс
В файле проекта под {$R *.res} пишем {$R Fonts.res}
|
1 2 |
{$R *.res} {$R Fonts.res} |
Получаем ресурс следующей фразой в файле проекта:
|
1 2 3 4 5 6 7 8 |
var FontResHandle: NativeUInt; begin FontResHandle := LoadResourceFontByName('IP_FONT','N2'); if FontResHandle = 0 then MessageDlg('Font not installed!', mtError, [mbOk], 0); ... end. |
Функция LoadResourceFontByName написана давно, но актуальности не потеряла:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
// Load Font from resource function LoadResourceFontByName(const ResourceName: string; ResType:PChar; AddFontInit : TGPFontAddInit = nil): NativeUInt; var ResStream : TResourceStream; FontsCount : DWORD; begin Result := 0; ResStream := TResourceStream.Create(hInstance, ResourceName, ResType); try Result := AddFontMemResourceEx(ResStream.Memory, ResStream.Size, nil, @FontsCount); if Assigned (AddFontInit) then AddFontInit (ResStream.Memory, ResStream.Size); finally ResStream.Free; end; end; |
AddFontMemResourceEx — подключает ресурс шрифта на время работы приложения. Больше никто в ОС этот шрифт не видит. По окончании работы надо вызвать RemoveFontMemResourceEx, но по утверждению Microsoft, ресурс освободится и так.
Все отлично работает, ресурс загружается, но по прежнему кракозяблы. Дело в том, что шрифт Segoe UI Symbol, уже есть, он системный, его даже удалить не получится. Попытка переименовать шрифт, скажем в Segoe UI Symbol 10, тоже не увенчается успехом. Переименовать typograph’ом получится, от кракозяблов избавиться — нет. GDI от семерки не вытягивает.
Поэтому, нам нужен хук, где будем рисовать шрифт с помощью GDI+.
GDI+ Нарисовать текст шрифтом из ресурса
Вообще, рисовать силами GDI+ замысловатые unicode символы из десятки можно даже в XP. Проверено. Надежно. Стильно. Для начала задействуем третий параметр AddFontInit : TGPFontAddInit функции LoadResourceFontByName.
|
1 2 |
type TGPFontAddInit = procedure (AMemory : Pointer; AMemSize : Integer); |
В файле проекта пишем следующую процедуру:
|
1 2 3 4 |
procedure GPFontAddInit(AMemory : Pointer; AMemSize : Integer); begin GPFontCollection.AddMemoryFont(AMemory, AMemSize); end; |
Модифицируем вызов функции загрузки шрифта.
|
1 |
FontResHandle := LoadResourceFontByName('IP_FONT','N2',GPFontAddInit); |
GPFontCollection — синглтон в модуле IP76.GDIPRoutines. Представлен таким образом:
|
1 2 3 4 5 6 7 8 9 10 11 |
var GxPFontCollection : TGPPrivateFontCollection = nil; function GPFontCollection(const AWithCreate: Boolean = True): TGPPrivateFontCollection; begin Result := GxPFontCollection; if Assigned(Result) or (not AWithCreate) then Exit; GxPFontCollection := TGPPrivateFontCollection.Create; Result := GxPFontCollection; end; |
Коллекция TGPPrivateFontCollection специализируется на хранении пользовательского перечня шрифтов. Что мы и делаем, загружая в нее шрифт из области памяти AMemory с помощью функции AddMemoryFont.
Рисуем текст функцией GDIPDrawTextEx из модуля IP76.GDIPRoutines, которая полностью повторяет список параметров процедуры DrawTextEx из модуля IP76.DrawUtils.
|
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 |
function GPFont(const AFont: TFont) : TGPFont; var fsl : FontStyle; begin fsl := GPFontStyle(AFont.Style); result := TGPFont.Create(AFont.Name, abs(AFont.Height), fsl, UnitPixel, GetFontCollection(AFont.Name)); end; function GDIPDrawTextEx(const ACanvas: TCanvas; const ARect : TRectF; const AText : string; const Alignment: TAlignment = taLeftJustify; const ALayout: TVerticalAlignment = taVerticalCenter; const AWordWrap: Boolean = False; const AClipped: Boolean = False; const AEllipsed: boolean = True ) : TStatus; var gp: TGPGraphics; sf: StringFormatFlags; gpsf: TGPStringFormat; font: TGPFont; brush: TGPBrush; begin Result := InvalidParameter; if not Assigned(ACanvas) then Exit; sf := $0000; if AWordWrap then sf := sf + StringFormatFlagsNoWrap; if not AClipped then sf := sf + StringFormatFlagsNoClip; gp := TGPGraphics.Create(ACanvas.Handle); font := GPFont(ACanvas.Font); brush := GPSolidBrush(ACanvas.Font.Color); gpsf := TGPStringFormat.Create(sf); try gpsf.SetAlignment(GetStringAlignment(Alignment)); gpsf.SetLineAlignment(GetStringLayout(ALayout)); if AEllipsed then gpsf.SetTrimming(StringTrimmingEllipsisCharacter) else gpsf.SetTrimming(StringTrimmingNone); gpsf.SetHotkeyPrefix(HotkeyPrefixHide); Result := gp.DrawString(AText, Length(AText), font, MakeRect(ARect.Left, ARect.Top, ARect.Width, ARect.Height), gpsf, brush); except Result := InvalidParameter; end; FreeAndNil(gpsf); FreeAndNil(brush); FreeAndNil(font); FreeAndNil(gp); end; |
Полный набор функций имеет смысл посмотреть в исходниках. Здесь указаны только те, которые имеют отношение непосредственно к делу.
TStyleHook для BitBtn
Если уж все равно будем рисовать, давайте окинем взглядом кнопки в текущем состоянии.
Что-то слишком уж черные и серых рамок разной степени серости в интерфейсе перебор. Пусть рамки будут только на полях отрисовки и элементах ввода данных. Рисовать символ в нормальном состоянии будем серым цветом, при наведении и фокусе цветом WebSteelBlue, рамка будет только у сфокусированного элемента.
|
1 2 3 4 5 |
TBitBtnStyleHookEx = class(TBitBtnStyleHook) strict protected procedure DrawButton(ACanvas: TCanvas; AMouseInControl: Boolean); override; end; |
Видим, что для BitBtn уже есть хук, и в принципе все устраивает, кроме отрисовки. Которую и переопределяем.
|
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 |
{ TBitBtnStyleHookEx } procedure TBitBtnStyleHookEx.DrawButton(ACanvas: TCanvas; AMouseInControl: Boolean); var Details: TThemedElementDetails; DrawRect: TRect; begin if not (Control is TBitBtn) then begin inherited; Exit; end; DrawRect := Control.ClientRect; if FPressed then Details := StyleServices.GetElementDetails(tbPushButtonPressed) else if AMouseInControl then Details := StyleServices.GetElementDetails(tbPushButtonHot) else if Focused or TBitBtn(Control).Default then Details := StyleServices.GetElementDetails(tbPushButtonDefaulted) else if Control.Enabled then Details := StyleServices.GetElementDetails(tbPushButtonNormal) else Details := StyleServices.GetElementDetails(tbPushButtonDisabled); StyleServices.DrawElement(ACanvas.Handle, Details, DrawRect); with TBitBtn(Control) do begin ACanvas.Font := Font; if (AMouseInControl or Control.Focused) and Enabled then ACanvas.Font.Color := clFocus else if Enabled then ACanvas.Font.Color := clFont else ACanvas.Font.Color := clIP76LineColor; GDIPDrawTextEx(ACanvas, VRectF(DrawRect), Caption, taCenter, taVerticalCenter, False, True, False); if Control.Focused then begin InflateRect(DrawRect,-1,-1); ACanvas.Brush.Style := bsClear; ACanvas.Pen.Color := ACanvas.Font.Color; ACanvas.Rectangle(DrawRect); end; end; end; |
Регистрируем
|
1 |
TCustomStyleEngine.RegisterStyleHook(TBitBtn, TBitBtnStyleHookEx); |
И почти готово:
Рамки у нас берутся из этой строки
|
1 |
StyleServices.DrawElement(ACanvas.Handle, Details, DrawRect); |
Ну не перерисовывать же всю кнопку, когда почти все устраивает.
Поэтому делаем так. В событии OnResize формы, в цикл по компонентам дописываем следующее:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
for i := 0 to ComponentCount-1 do begin c := Components[i]; if c is TBitBtn then TBitBtn(Components[i]).Tag := RectreateControlRgn(TBitBtn(Components[i]), Rect(1,1,1,1), TBitBtn(Components[i]).Tag); if (c is TControl) and (TControl(c).Parent is TScrollBox) and IsParentForControl(TControl(c), pnlClient) then with TControl(c) do begin Anchors := Anchors - [akRight]; Width := TControl(c).Parent.ClientWidth - Left - 3; end; end; |
При всяком изменении размеров и как следствие географии расположения кнопок, пересоздаем для кнопки регион, который на пиксель меньше прямоугольника кнопки. Описатель региона помещается в свойство Tag кнопки.
|
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 |
// Set new region in AControl with AMargin offset function RectreateControlRgn(const AControl: TWinControl; const AMargin: TRect; var ARGN: HRGN): Boolean; overload; var rct: TRect; begin if ARGN <> 0 then DeleteObject(ARGN); rct := AControl.ClientRect; rct.Top := rct.Top + AMargin.Top; rct.Left := rct.Left + AMargin.Left; rct.Right := rct.Right - AMargin.Right; rct.Bottom := rct.Bottom - AMargin.Bottom; ARGN := CreateRectRgn(rct.Left, rct.Top, rct.Right, rct.Bottom); Result := SetWindowRgn(AControl.Handle, ARGN, TRUE) <> 0; end; function RectreateControlRgn(const AControl: TWinControl; const AMargin: TRect; const ARGN: NativeInt): NativeInt; overload; var rgn: HRGN; begin rgn := ARGN; RectreateControlRgn(AControl, AMargin, rgn); Result := rgn; end; |
И сразу проверяем на Windows 7.
Левая подсвеченная кнопка с рамкой — под фокусом. Правая подсвеченная кнопка — под мышью. И никаких кракозяблов.
Еще одной проблемой меньше. В другом проекте будет другая тема и другие украшения. Важен подход, принцип решения.
PageControl без рамки
В дополнение к теме региона. Центральная панель, на которой расположены элементы управления и настройки, на самом деле PageControl. У которого отключено свойство TabVisible для всех вкладок. С отключенными вкладками он выглядит так:
Снова серая рамка, да еще с утолщением справа-снизу. Поэтому применяем тот же метод, что и для BitBtn.
|
1 |
pgc.Tag := RectreateControlRgn(pgc, Rect(4,2,2,2), pgc.Tag); |
Переключение вкладок осуществляется в выпадающем списке сверху. Зачем вообще появился PageControl.
Подразумевается, что список эффектов будет расширяться, и вкладки перестанут быть удобным средством навигации. Их будет много и в несколько рядов. В этом случае логичней выбирать из выпадающего списка. Но с другой стороны, на PageControl удобно размещать и настраивать элементы в дизайне. Поэтому видимость с вкладок снимается уже в Real-Time, в обработчике OnCreate формы.
TStyleHook для Checkbox Switch
Нравится мне эта тема с переключателями вместо галочки Checkbox’а. И очень не нравится рамка из точек на сфокусированном checkbox’е.
Поэтому делаем хук для Сheckbox’а и заодно для RadioButton.
|
1 2 3 4 5 6 |
TCheckBoxStyleHookEx = class(TCheckBoxStyleHook) protected function RightAlignment: Boolean; public procedure Paint(Canvas: TCanvas); override; end; |
Переписываем всю отрисовку. Много кода, поэтому в спойлере.
|
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 |
{ TCheckBoxStyleHookEx } function TCheckBoxStyleHookEx.RightAlignment: Boolean; begin Result := (Control.BiDiMode = bdRightToLeft) or (GetWindowLong(Handle, GWL_STYLE) and BS_RIGHTBUTTON = BS_RIGHTBUTTON); end; function TCheckBoxStyleHookEx.GetBoxSize(DC: HDC): Size; begin Result.cx := 13; Result.cy := 13; if StyleServices.Enabled then with StyleServices do begin if not GetElementSize(DC, GetElementDetails(tbCheckBoxCheckedNormal), System.Classes.Rect(0, 0, 20, 20), esActual, Result) then begin Result.cx := 13; Result.cy := 13; end; end; end; type TMyCheckBox = class(TButtonControl); procedure TCheckBoxStyleHookEx.Paint(Canvas: TCanvas); var State: TCheckBoxState; R: TRect; BoxSize: TSize; LCaption: string; Spacing: Integer; Alignment: TAlignment; RightAlignment: Boolean; bmp: TBitmap; begin State := TCheckBoxState(SendMessage(Handle, BM_GETCHECK, 0, 0)); if not (Control is TButtonControl) then Exit; if Control is TCheckBox then Alignment := TCheckBox(Control).Alignment else if Control is TRadioButton then Alignment := TRadioButton(Control).Alignment else Alignment := taRightJustify; RightAlignment := (Control.BiDiMode <> bdLeftToRight); RightAlignment := (RightAlignment and (Alignment = taRightJustify)) or (not RightAlignment and (Alignment = taLeftJustify)); Spacing := 3; if not RightAlignment then begin if Alignment = taLeftJustify then Alignment := taRightJustify else Alignment := taLeftJustify; end; BoxSize := GetBoxSize(Canvas.Handle); if Control is TRadioButton then BoxSize.cy := BoxSize.cx else BoxSize.cx := BoxSize.cx * 2; R := Rect(0, 0, BoxSize.cx, BoxSize.cy); if (not RightAlignment) then RectVCenter(R, Rect(0, 0, Control.Width, Control.Height)) else RectVCenter(R, Rect(Control.Width - BoxSize.cx - 1, 0, Control.Width, Control.Height)); bmp := TBitmap.Create; try bmp.SetSize(Control.Width, Control.Height); bmp.Canvas.Brush.Color := TMyCheckBox(Control).Color; bmp.Canvas.FillRect(Rect(0, 0, Control.Width, Control.Height)); bmp.Canvas.Font := TMyCheckBox(Control).Font; DrawSwitch(bmp.Canvas, R, State, Control.Enabled, Control is TRadioButton); Spacing := Spacing + BoxSize.cy div 2; R := Rect(0, 0, Control.Width - BoxSize.cx - 7 - SPacing, Control.Height); LCaption := TMyCheckBox(Control).Text; if (not RightAlignment) then RectVCenter(R, Rect(BoxSize.cx + Spacing, 0, Control.Width, Control.Height)) else begin if Control.BiDiMode = bdLeftToRight then RectVCenter(R, Rect(3, 0, Control.Width - BoxSize.cx - Spacing, Control.Height)) else if Alignment = taLeftJustify then RectVCenter(R, Rect(BoxSize.cx + Spacing, 0, Control.Width - BoxSize.cx - Spacing, Control.Height)) else RectVCenter(R, Rect(Control.Width-BoxSize.cx-Spacing-R.Right, 0, Control.Width-BoxSize.cx-Spacing, Control.Height)); end; if (IsMouseInControl or Control.Focused) and (Control.Enabled) then begin end else if Control.Enabled then else bmp.Canvas.Font.Color := clBtnShadow; if (not RightAlignment) and (Control.BiDiMode <> bdLeftToRight) and (Alignment = taRightJustify) then Alignment := taLeftJustify; DrawTextEx(bmp.Canvas, R, LCaption, Alignment, taVerticalCenter, TMyCheckBox(Control).WordWrap, True, True); if Control.Focused then begin InflateRect(R,3,0); bmp.Canvas.Brush.Style := bsClear; bmp.Canvas.Pen.Color := clFont; bmp.Canvas.Rectangle(R); end; finally Canvas.Draw(0,0,bmp); FreeANdNil(bmp); end; end; |
Регистрируем:
|
1 2 3 4 |
TCustomStyleEngine.RegisterStyleHook(TCheckBox, TCheckBoxStyleHookEx); TCustomStyleEngine.RegisterStyleHook(TRadioButton, TCheckBoxStyleHookEx); |
На всякий случай рисовашка для переключателя. Конечно GDI+, нужны плавные закругления. Код также оформлен спойлером, чтобы не загромождать.
|
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 |
function DrawSwitch(const ACanvas: TCanvas; const ARect: TRect; const AState: TCheckBoxState; const AEnabled: Boolean = True; const ARadioButton: Boolean = False): Boolean; var gp: TGPGraphics; rct: TRect; clr: TColor; pen: TGPPen; path: TGPGraphicsPath; brush: TGPSolidBrush; begin Result := Assigned(ACanvas) and (ARect.Width>0) and (ARect.Height > 0); if not Result then Exit; gp := TGPGraphics.Create(ACanvas.Handle); pen := nil; path := nil; brush := nil; rct := ARect; try gp.SetSmoothingMode(SmoothingModeAntiAlias8x4); if not AEnabled then clr := ColorToRGB(clBtnShadow) else case AState of cbUnchecked : clr := clUnchecked; cbchecked : clr := clChecked; else clr := clBtnShadow; end; pen := TGPPen.Create(MakeColor(GetRValue(clr),GetGValue(clr),GetBValue(clr)),1.0); brush := TGPSolidBrush.Create(MakeColor(GetRValue(clr),GetGValue(clr),GetBValue(clr))); path := TGPGraphicsPath.Create; path.StartFigure; path.AddArc(rct.Left,rct.Top,rct.Height,rct.Height,90,180); path.AddArc(rct.Right-rct.Height,rct.Top,rct.Height,rct.Height,270,180); path.CloseFigure; gp.FillPath(brush,path); gp.DrawPath(pen,path); case AState of cbUnchecked : rct.Right := rct.Left + rct.Height; cbChecked : rct.Left := rct.Right - rct.Height; else begin OffsetRect(rct, (rct.Width - rct.Height) div 2, 0); rct.Right := rct.Left + rct.Height; end; end; FreeAndNil(brush); if AEnabled then clr := clWhite else clr := ColorToRGB(clBtnFace); brush := TGPSolidBrush.Create(MakeColor(GetRValue(clr),GetGValue(clr),GetBValue(clr))); InflateRect(rct,-1,-1); if (AState = cbChecked) or not ARadioButton then gp.FillEllipse(brush, rct.Left, rct.Top, rct.Width, rct.Height); finally FreeAndNil(pen); FreeAndNil(path); FreeAndNil(brush); FreeAndNil(gp); end; end; |
Получилось следующее:
Симпатично получилось. Вместо точечного фрейма элемент под фокусом обрамляет прямоугольник в стиле темы.
Ну и наконец, TrackBar.
TStyleHook для TrackBar
А с ним-то что не так? Да все та же рамка из точек. Выпадает из стиля.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
TTrackBarStyleHookEx = class(TTrackBarStyleHook) protected procedure Paint(Canvas: TCanvas); override; end; procedure TTrackBarStyleHookEx.Paint(Canvas: TCanvas); begin inherited Paint(Canvas); if Focused then begin Canvas.Brush.Style := bsClear; Canvas.Pen.Color := clIP76LineColor; Canvas.Rectangle(Rect(0, 0, Control.Width, Control.Height)); end; end; |
Мы со всем согласны, только если компонент под фокусом, рисуем рамку из точек, затирая тем самым уже существующий фрейм, и рисуем поверх светло-серый прямоугольник.
Баги
Дергается окно темы
К сожалению, это так. При растяжении по вертикали, окно припадочно меняет размер. Это не добавляет красоты проекту. Поэтому в свойстве StyleElements формы ставим везде FALSE. Рамка окна приобрела обычный для текущей ОС вид. Зато и поведение стало обычным — без рывков. Не самая большая жертва.
Моргает надпись «not supported»
Тоже неприятный момент. Эта надпись появляется в Windows 7, так как имеет на борту Direct2D версии 1.0 и никакого контекста, и никаких эффектов, в нем нет. На рис.3. эта надпись продемонстрирована. Моргает при изменении размеров окна. Лечится заменой TLabel на TStaticText.
Анонс. Direct2D компонент
Возник вопрос, можно ли использовать Direct2D при написании визуальных компонент. Можно. О чем свидетельствует рисунок ниже.
Компонент рисует текст с контуром и тенью, о чем не так давно говорили. При наведении мышью окрашивается справа налево цветом контура. При «уходе» мыши с компонента, окрашивание «уходит» слева направо. На рис.7. мышь наведена на слово «Effects».
Хочется сказать, что использовать Direct2D для таких компонент — непростительная роскошь. Все это можно сделать силами GDI+. Смысл использовать Direct2D возникает для очень больших отрисовок. Графиков, диаграмм, инфографики. Когда между BeginDraw и EndDraw много действий, много рисовки.
О компонентах Direct2D, надеюсь, удастся поговорить попозже. Пока Light-реализацию конкретно для этого проекта можно подсмотреть в исходниках.
Ни Direct2D, ни компоненты, темой статьи не являются, поэтому будет развернуто в следующих статьях.
Друзья, спасибо за внимание!
Надеюсь, материал был полезен.
В следующей статье будут рассмотрены фото эффекты Direct2D, такие как: яркость, контрастность, резкость, инверсия, сепия, виньетка и другие.
Не пропустите, подписывайтесь на телегу.
Если есть вопросы, с удовольствием отвечу.
Скачать
Исходники (Delphi XE 7-10) 2.8 Мб
Исполняемый файл 2.6 Мб