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.