Using XE2 VCL styles, I'd like to disable the skinning for TLabel (or property sfTextLabelNormal)
I've tried all kind of solutions from other questions, like using Engine.UnRegisterStyleHook, but it has no effect.
The TLabel component doesn't use styles hooks because is not a TWinControl descendant, so you can't use the UnRegisterStyleHook
function. Instead you must override the Paint DoDrawText
method.
UPDATE
Here you have a sample of how override the paint process of a TLabel.
//declare this code in the implementation part
uses
Vcl.Themes,
Vcl.Styles;
type
TLabelHelper= class helper for TCustomLabel
procedure DrawNormalText(DC: HDC; const Text: UnicodeString; var TextRect: TRect; TextFlags: Cardinal);
end;
{ TLabelHelper }
procedure TLabelHelper.DrawNormalText(DC: HDC; const Text: UnicodeString;
var TextRect: TRect; TextFlags: Cardinal);
begin
Self.DoDrawNormalText(DC, Text, TextRect, TextFlags);
end;
{ TLabel }
procedure TLabel.DoDrawText(var Rect: TRect; Flags: Integer);
const
EllipsisStr = '...';
Ellipsis: array[TEllipsisPosition] of Longint = (0, DT_PATH_ELLIPSIS, DT_END_ELLIPSIS, DT_WORD_ELLIPSIS);
var
Text, DText: string;
NewRect: TRect;
Height, Delim: Integer;
begin
Text := GetLabelText;
if (Flags and DT_CALCRECT <> 0) and
((Text = '') or ShowAccelChar and (Text[1] = '&') and (Length(Text) = 1)) then
Text := Text + ' ';
if Text <> '' then
begin
if not ShowAccelChar then Flags := Flags or DT_NOPREFIX;
Flags := DrawTextBiDiModeFlags(Flags);
Canvas.Font := Font;
if (EllipsisPosition <> epNone) and not AutoSize then
begin
DText := Text;
Flags := Flags and not DT_EXPANDTABS;
Flags := Flags or Ellipsis[EllipsisPosition];
if WordWrap and (EllipsisPosition in [epEndEllipsis, epWordEllipsis]) then
begin
repeat
NewRect := Rect;
Dec(NewRect.Right, Canvas.TextWidth(EllipsisStr));
DrawNormalText(Canvas.Handle, DText, NewRect, Flags or DT_CALCRECT);
Height := NewRect.Bottom - NewRect.Top;
if (Height > ClientHeight) and (Height > Canvas.Font.Height) then
begin
Delim := LastDelimiter(' '#9, Text);
if Delim = 0 then
Delim := Length(Text);
Dec(Delim);
if ByteType(Text, Delim) = mbLeadByte then
Dec(Delim);
Text := Copy(Text, 1, Delim);
DText := Text + EllipsisStr;
if Text = '' then
Break;
end else
Break;
until False;
end;
if Text <> '' then
Text := DText;
end;
if Enabled or StyleServices.Enabled then
DrawNormalText(Canvas.Handle, Text, Rect, Flags)
else
begin
OffsetRect(Rect, 1, 1);
Canvas.Font.Color := clBtnHighlight;
DrawNormalText(Canvas.Handle, Text, Rect, Flags);
OffsetRect(Rect, -1, -1);
Canvas.Font.Color := clBtnShadow;
DrawNormalText(Canvas.Handle, Text, Rect, Flags);
end;
end;
end;
before to use it declare an interposer class in this way
TLabel = class (Vcl.StdCtrls.TLabel)
procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
end;
And this is the result
Some modyfication RRUZ's solution (complete component, less writing):
type
TjsLabel = class(TLabel)
private
FDisableTheme: Boolean;
procedure SetDisableTheme(const Value: Boolean);
protected
public
procedure Invalidate;override;
published
property DisableTheme:Boolean read FDisableTheme write SetDisableTheme;
end;
procedure Register;
implementation
uses Themes, Styles;
type
TLabelHelper = class helper for TCustomLabel
procedure SetThemeBehavior(const AEnableTheme:Boolean);
end;
procedure Register;
begin
RegisterComponents('JS', [TJSLabel]);
end;
procedure TJSLabel.Invalidate;
begin
SetThemeBehavior(not DisableTheme);
inherited;
end;
procedure TJSLabel.SetDisableTheme(const Value: Boolean);
begin
if FDisableTheme <> Value then
begin
FDisableTheme := Value;
SetThemeBehavior(not Value);
end;
end;
{ TLabelHelper }
procedure TLabelHelper.SetThemeBehavior(const AEnableTheme: Boolean);
begin
Self.FDrawTextProc := Self.DoDrawNormalText;
if AEnableTheme then
if StyleServices.Enabled then
Self.FDrawTextProc := Self.DoDrawThemeTextEx
end;
来源:https://stackoverflow.com/questions/9995080/delphi-xe2-vcl-styles-remove-a-style-or-disable-a-class-skinning-from-a-tlabel