369 lines
10 KiB
Plaintext
369 lines
10 KiB
Plaintext
|
unit GlowLabel;
|
||
|
|
{******************************************************************}
|
||
|
|
{ GlowLabel }
|
||
|
|
{ }
|
||
|
|
{ home page : http://www.winningcubed.de }
|
||
|
|
{ email : martin.walter@winningcubed.de }
|
||
|
|
{ }
|
||
|
|
{ date : 15-04-2007 }
|
||
|
|
{ }
|
||
|
|
{ version : 1.0 }
|
||
|
|
{ }
|
||
|
|
{ Use of this file is permitted for commercial and non-commercial }
|
||
|
|
{ use, as long as the author is credited. }
|
||
|
|
{ This file (c) 2007 Martin Walter }
|
||
|
|
{ }
|
||
|
|
{ This Software is distributed on an "AS IS" basis, WITHOUT }
|
||
|
|
{ WARRANTY OF ANY KIND, either express or implied. }
|
||
|
|
{ }
|
||
|
|
{ *****************************************************************}
|
||
|
|
|
||
|
|
|
||
|
|
interface
|
||
|
|
|
||
|
|
uses
|
||
|
|
Windows, Classes, StdCtrls {$IFDEF USETNT}, TntStdCtrls{$ENDIF};
|
||
|
|
|
||
|
|
type
|
||
|
|
TCustomGlowLabel = class({$IFDEF USETNT}TTntCustomLabel{$ELSE}TCustomLabel{$ENDIF})
|
||
|
|
private
|
||
|
|
FGlow: Boolean;
|
||
|
|
FGlowSize: Integer;
|
||
|
|
FOldGlowSize: Integer;
|
||
|
|
FBoundsWithGlow: Boolean;
|
||
|
|
procedure SetGlow(const Value: Boolean);
|
||
|
|
procedure SetGlowSize(const Value: Integer);
|
||
|
|
|
||
|
|
function IsGlow: Boolean;
|
||
|
|
function GetExpansion(GlowSize: Integer): Integer;
|
||
|
|
protected
|
||
|
|
procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
|
||
|
|
procedure AdjustBounds; override;
|
||
|
|
property Glow: Boolean read FGlow write SetGlow;
|
||
|
|
property GlowSize: Integer read FGlowSize write SetGlowSize;
|
||
|
|
public
|
||
|
|
constructor Create(AOwner: TComponent); override;
|
||
|
|
end;
|
||
|
|
|
||
|
|
TGlowLabel = class(TCustomGlowLabel)
|
||
|
|
published
|
||
|
|
property Align;
|
||
|
|
property Alignment;
|
||
|
|
property Anchors;
|
||
|
|
property AutoSize;
|
||
|
|
property BiDiMode;
|
||
|
|
property Caption;
|
||
|
|
property Color nodefault;
|
||
|
|
property Constraints;
|
||
|
|
property DragCursor;
|
||
|
|
property DragKind;
|
||
|
|
property DragMode;
|
||
|
|
property EllipsisPosition;
|
||
|
|
property Enabled;
|
||
|
|
property FocusControl;
|
||
|
|
property Font;
|
||
|
|
property Glow;
|
||
|
|
property GlowSize;
|
||
|
|
property ParentBiDiMode;
|
||
|
|
property ParentColor;
|
||
|
|
property ParentFont;
|
||
|
|
property ParentShowHint;
|
||
|
|
property PopupMenu;
|
||
|
|
property ShowAccelChar;
|
||
|
|
property ShowHint;
|
||
|
|
property Transparent;
|
||
|
|
property Layout;
|
||
|
|
property Visible;
|
||
|
|
property WordWrap;
|
||
|
|
property OnClick;
|
||
|
|
property OnContextPopup;
|
||
|
|
property OnDblClick;
|
||
|
|
property OnDragDrop;
|
||
|
|
property OnDragOver;
|
||
|
|
property OnEndDock;
|
||
|
|
property OnEndDrag;
|
||
|
|
property OnMouseActivate;
|
||
|
|
property OnMouseDown;
|
||
|
|
property OnMouseMove;
|
||
|
|
property OnMouseUp;
|
||
|
|
property OnMouseEnter;
|
||
|
|
property OnMouseLeave;
|
||
|
|
property OnStartDock;
|
||
|
|
property OnStartDrag;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure Register;
|
||
|
|
|
||
|
|
implementation
|
||
|
|
|
||
|
|
uses
|
||
|
|
Controls, Forms, Graphics, SysUtils, Math, DwmApi, Themes, UxTheme;
|
||
|
|
|
||
|
|
function StrScanW(const Str: PWideChar; Chr: WideChar): PWideChar;
|
||
|
|
begin
|
||
|
|
Result := Str;
|
||
|
|
while Result^ <> Chr do
|
||
|
|
begin
|
||
|
|
if Result^ = #0 then
|
||
|
|
begin
|
||
|
|
Result := nil;
|
||
|
|
Exit;
|
||
|
|
end;
|
||
|
|
Inc(Result);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function LastDelimiterW(const Delimiters, S: WideString): Integer;
|
||
|
|
var
|
||
|
|
P: PWideChar;
|
||
|
|
begin
|
||
|
|
Result := Length(S);
|
||
|
|
P := PWideChar(Delimiters);
|
||
|
|
while Result > 0 do
|
||
|
|
begin
|
||
|
|
if (S[Result] <> #0) and (StrScanW(P, S[Result]) <> nil) then
|
||
|
|
Exit;
|
||
|
|
|
||
|
|
Dec(Result);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
{ TGlowCustomLabel }
|
||
|
|
|
||
|
|
procedure TCustomGlowLabel.AdjustBounds;
|
||
|
|
const
|
||
|
|
WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
|
||
|
|
var
|
||
|
|
DC: HDC;
|
||
|
|
Rect, Bounds, CalcRect: TRect;
|
||
|
|
AAlignment: TAlignment;
|
||
|
|
Expand: Integer;
|
||
|
|
DoSetBounds: Boolean;
|
||
|
|
begin
|
||
|
|
DoSetBounds := False;
|
||
|
|
Bounds := BoundsRect;
|
||
|
|
Rect := Bounds;
|
||
|
|
|
||
|
|
if (IsGlow and (csReading in ComponentState)) then
|
||
|
|
begin
|
||
|
|
FBoundsWithGlow := True;
|
||
|
|
FOldGlowSize := FGlowSize;
|
||
|
|
end;
|
||
|
|
|
||
|
|
if FBoundsWithGlow then
|
||
|
|
begin
|
||
|
|
Expand := GetExpansion(FOldGlowSize);
|
||
|
|
Inc(Rect.Left, Expand);
|
||
|
|
Inc(Rect.Top, Expand);
|
||
|
|
Dec(Rect.Right, Expand);
|
||
|
|
Dec(Rect.Bottom, Expand);
|
||
|
|
FBoundsWithGlow := False;
|
||
|
|
DoSetBounds := True;
|
||
|
|
end;
|
||
|
|
|
||
|
|
if not ((csReading in ComponentState) or
|
||
|
|
(csLoading in ComponentState)) and
|
||
|
|
AutoSize then
|
||
|
|
begin
|
||
|
|
DC := GetDC(0);
|
||
|
|
Canvas.Handle := DC;
|
||
|
|
CalcRect.Left := 0;
|
||
|
|
CalcRect.Top := 0;
|
||
|
|
DoDrawText(CalcRect, (DT_EXPANDTABS or DT_CALCRECT) or WordWraps[WordWrap]);
|
||
|
|
Canvas.Handle := 0;
|
||
|
|
ReleaseDC(0, DC);
|
||
|
|
AAlignment := Alignment;
|
||
|
|
if UseRightToLeftAlignment then
|
||
|
|
ChangeBiDiModeAlignment(AAlignment);
|
||
|
|
|
||
|
|
if AAlignment = taRightJustify then
|
||
|
|
Rect.Left := Rect.Right - CalcRect.Right;
|
||
|
|
|
||
|
|
Rect.Right := Rect.Left + CalcRect.Right;
|
||
|
|
Rect.Bottom := Rect.Top + CalcRect.Bottom;
|
||
|
|
DoSetBounds := True;
|
||
|
|
end;
|
||
|
|
|
||
|
|
if IsGlow then
|
||
|
|
begin
|
||
|
|
FBoundsWithGlow := True;
|
||
|
|
Expand := GetExpansion(FGlowSize);
|
||
|
|
Dec(Rect.Left, Expand);
|
||
|
|
Dec(Rect.Top, Expand);
|
||
|
|
Inc(Rect.Right, Expand);
|
||
|
|
Inc(Rect.Bottom, Expand);
|
||
|
|
FOldGlowSize := FGlowSize;
|
||
|
|
DoSetBounds := True;
|
||
|
|
end;
|
||
|
|
|
||
|
|
if DoSetBounds then
|
||
|
|
SetBounds(Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
|
||
|
|
end;
|
||
|
|
|
||
|
|
constructor TCustomGlowLabel.Create(AOwner: TComponent);
|
||
|
|
begin
|
||
|
|
inherited;
|
||
|
|
FGlow := False;
|
||
|
|
FGlowSize := 10;
|
||
|
|
FOldGlowSize := 0;
|
||
|
|
FBoundsWithGlow := False;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TCustomGlowLabel.DoDrawText(var Rect: TRect; Flags: Integer);
|
||
|
|
|
||
|
|
procedure DoDrawThemeTextEx(DC: HDC; const Text: WideString; TextLen: Integer;
|
||
|
|
var TextRect: TRect; TextFlags: Cardinal);
|
||
|
|
var
|
||
|
|
Options: TDTTOpts;
|
||
|
|
begin
|
||
|
|
FillChar(Options, SizeOf(Options), 0);
|
||
|
|
Options.dwSize := SizeOf(Options);
|
||
|
|
Options.dwFlags := DTT_TEXTCOLOR or DTT_COMPOSITED;
|
||
|
|
if IsGlow then
|
||
|
|
begin
|
||
|
|
Options.dwFlags := Options.dwFlags or DTT_GLOWSIZE;
|
||
|
|
Options.iGlowSize := FGlowSize;
|
||
|
|
end;
|
||
|
|
Options.crText := ColorToRGB(Canvas.Font.Color);
|
||
|
|
|
||
|
|
with ThemeServices.GetElementDetails(teEditTextNormal) do
|
||
|
|
DrawThemeTextEx(ThemeServices.Theme[teEdit], DC, Part, State,
|
||
|
|
PWideChar(Text), TextLen, TextFlags, @TextRect, Options);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure DrawText(DC: HDC; const Text: WideString; TextLen: Integer;
|
||
|
|
var TextRect: TRect; TextFlags: Cardinal);
|
||
|
|
var
|
||
|
|
LForm: TCustomForm;
|
||
|
|
PaintOnGlass: Boolean;
|
||
|
|
Expand: Integer;
|
||
|
|
begin
|
||
|
|
PaintOnGlass := ThemeServices.ThemesEnabled and DwmCompositionEnabled and
|
||
|
|
not (csDesigning in ComponentState);
|
||
|
|
if PaintOnGlass then
|
||
|
|
begin
|
||
|
|
LForm := GetParentForm(Self);
|
||
|
|
PaintOnGlass := (LForm <> nil) and LForm.GlassFrame.FrameExtended and
|
||
|
|
LForm.GlassFrame.IntersectsControl(Self);
|
||
|
|
end;
|
||
|
|
|
||
|
|
if IsGlow and (Flags and DT_CALCRECT = 0) then
|
||
|
|
begin
|
||
|
|
Expand := GetExpansion(FGlowSize);
|
||
|
|
case Alignment of
|
||
|
|
taLeftJustify: OffsetRect(TextRect, Expand, 0);
|
||
|
|
taRightJustify: OffsetRect(TextRect, -Expand, 0);
|
||
|
|
end;
|
||
|
|
|
||
|
|
case Layout of
|
||
|
|
tlTop: OffsetRect(TextRect, 0, Expand);
|
||
|
|
tlBottom: OffsetRect(TextRect, 0, -Expand);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
if PaintOnGlass and (Flags and DT_CALCRECT = 0) then
|
||
|
|
DoDrawThemeTextEx(DC, Text, TextLen, TextRect, TextFlags)
|
||
|
|
else
|
||
|
|
Windows.DrawTextW(DC, PWideChar(Text), TextLen, TextRect, TextFlags);
|
||
|
|
end;
|
||
|
|
|
||
|
|
const
|
||
|
|
EllipsisStr = '...';
|
||
|
|
Ellipsis: array[TEllipsisPosition] of Longint = (0, DT_PATH_ELLIPSIS,
|
||
|
|
DT_END_ELLIPSIS, DT_WORD_ELLIPSIS);
|
||
|
|
var
|
||
|
|
Text, DText: WideString;
|
||
|
|
NewRect: TRect;
|
||
|
|
Height, Delim: Integer;
|
||
|
|
begin
|
||
|
|
Text := Caption;
|
||
|
|
if (Flags and DT_CALCRECT <> 0) and ((Text = '') or ShowAccelChar and
|
||
|
|
(Text[1] = '&') and (Text[2] = #0)) then
|
||
|
|
Text := Text + ' ';
|
||
|
|
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));
|
||
|
|
Windows.DrawTextW(Canvas.Handle, PWideChar(DText), Length(DText), NewRect, Flags or DT_CALCRECT);
|
||
|
|
Height := NewRect.Bottom - NewRect.Top;
|
||
|
|
if (Height > ClientHeight) and (Height > Canvas.Font.Height) then
|
||
|
|
begin
|
||
|
|
Delim := LastDelimiterW(' '#9, Text);
|
||
|
|
if Delim = 0 then
|
||
|
|
Delim := Length(Text);
|
||
|
|
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 not Enabled then
|
||
|
|
begin
|
||
|
|
OffsetRect(Rect, 1, 1);
|
||
|
|
Canvas.Font.Color := clBtnHighlight;
|
||
|
|
DrawText(Canvas.Handle, Text, Length(Text), Rect, Flags);
|
||
|
|
OffsetRect(Rect, -1, -1);
|
||
|
|
Canvas.Font.Color := clBtnShadow;
|
||
|
|
DrawText(Canvas.Handle, Text, Length(Text), Rect, Flags);
|
||
|
|
end
|
||
|
|
else
|
||
|
|
DrawText(Canvas.Handle, Text, Length(Text), Rect, Flags);
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TCustomGlowLabel.GetExpansion(GlowSize: Integer): Integer;
|
||
|
|
begin
|
||
|
|
Result := Ceil(GlowSize / 2) + 1;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function TCustomGlowLabel.IsGlow: Boolean;
|
||
|
|
begin
|
||
|
|
Result := FGlow and (FGlowSize > 0);
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TCustomGlowLabel.SetGlow(const Value: Boolean);
|
||
|
|
begin
|
||
|
|
if FGlow <> Value then
|
||
|
|
begin
|
||
|
|
FGlow := Value;
|
||
|
|
AdjustBounds;
|
||
|
|
Invalidate;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure TCustomGlowLabel.SetGlowSize(const Value: Integer);
|
||
|
|
begin
|
||
|
|
if FGlowSize <> Value then
|
||
|
|
begin
|
||
|
|
FGlowSize := Value;
|
||
|
|
AdjustBounds;
|
||
|
|
Invalidate;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
|
||
|
|
procedure Register;
|
||
|
|
begin
|
||
|
|
RegisterComponents('MWK', [TGlowLabel]);
|
||
|
|
end;
|
||
|
|
|
||
|
|
end.
|