Стили Delphi XE2 VCL, удаление стиля или отключение скинов класса из TLabel

Используя стили XE2 VCL, я хотел бы отключить скиннинг для TLabel (или свойство sfTextLabelNormal)

Я пробовал всевозможные решения из других вопросов, например, с помощью Engine.UnRegisterStyleHook, но это не дало никакого эффекта.


delphi skinning vcl delphi-xe2 vcl-styles
person hikari    schedule 03.04.2012    source источник
comment
Может быть немного меньше работы, если просто заменить этот TLabel на TPaintbox и нарисовать его самостоятельно.   -  person Warren P    schedule 03.04.2012

Ответы (2)


arrow_upward
10
arrow_downward

Компонент TLabel не использует перехватчики стилей, поскольку не является < потомок href="http://docwiki.embarcadero.com/Libraries/en/Vcl.Controls.TWinControl" rel="nofollow noreferrer">TWinControl, поэтому вы не можете использовать UnRegisterStyleHook. Вместо этого вы должны переопределить Paint DoDrawText метод.

ОБНОВЛЕНИЕ

Здесь у вас есть пример того, как переопределить процесс рисования 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;

прежде чем использовать его, объявите класс интерпозера таким образом

  TLabel = class (Vcl.StdCtrls.TLabel)
    procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
  end;

И это результат

введите здесь описание изображения

person RRUZ    schedule 03.04.2012
comment
Не могли бы вы привести пример переопределения? достаточно просто сохранить цвет шрифта и т. д. Спасибо. - person hikari; 04.04.2012
comment
У меня была та же проблема, что и выше, и это решение было элегантным и минималистичным, поэтому +1 от меня =] - person Kieran Wilson; 31.10.2012
comment
Это спасло мне жизнь :D - person Jerry Dodge; 14.04.2014
comment
@hikari, этот ответ был сделан, когда свойство StyleElements еще не было введено. В новых версиях Delphi вам нужно использовать это свойство только для отключения стиля файла TLabel. Поэтому просто удалите элемент `SeFont` этого свойства, и TLabel будет использовать определенный пользовательский цвет. - person RRUZ; 10.01.2017

arrow_upward
1
arrow_downward

Некоторая модификация решения RRUZ (полный компонент, меньше написания):

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;
person stoklosa    schedule 21.06.2012