使用XE2 VCL样式,我想为TLabel(或属性sfTextLabelNormal)禁用外观
我已尝试过其他问题的所有解决方案,例如使用Engine.UnRegisterStyleHook,但它没有效果。
答案 0 :(得分:10)
TLabel组件不使用样式挂钩,因为它不是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;
这是结果
答案 1 :(得分:1)
一些修改CRUZ的解决方案(完整的组件,更少的写作):
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;