Delphi XE2 VCL style, remove style or disable class skin from TLabel
2 answers
The TLabel component does not use style bindings because it is not a TWinControl , so you cannot use the function UnRegisterStyleHook
. Instead, you must override the Paint method DoDrawText
.
UPDATE
Here you have a sample of how to override the TLabel drawing process.
//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 using it, declare your interpolator class like this
TLabel = class (Vcl.StdCtrls.TLabel)
procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
end;
And this is the result
+10
source to share
Some RRUZ solution for modyfication (full component, less write):
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;
+1
source to share