使用XE2 VCL样式,我希望禁用TLabel的皮肤效果(或属性sfTextLabelNormal)。
我尝试了其他问题中提供的各种解决方案,例如使用Engine.UnRegisterStyleHook,但没有效果。
使用XE2 VCL样式,我希望禁用TLabel的皮肤效果(或属性sfTextLabelNormal)。
我尝试了其他问题中提供的各种解决方案,例如使用Engine.UnRegisterStyleHook,但没有效果。
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;
在使用之前,需通过以下方式声明一个interposer类
TLabel = class (Vcl.StdCtrls.TLabel)
procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
end;
这就是结果
StyleElements
属性尚未引入时制作的。使用新版本的Delphi,您只需要使用此属性来禁用TLabel
的样式。因此,只需删除此属性的SeFont
元素,TLabel将使用定义的自定义颜色。 - RRUZ对 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;