{********************************************************************}
{                                                                    }
{ written by TMS Software                                            }
{            copyright © 2013                                        }
{            Email : info@tmssoftware.com                            }
{            Web : http://www.tmssoftware.com                        }
{                                                                    }
{ The source code is given as is. The author is not responsible      }
{ for any possible damage done due to the use of this code.          }
{ The complete source code remains property of the author and may    }
{ not be distributed, published, given or sold in any form as such.  }
{ No parts of the source code can be included in any other component }
{ or application without written authorization of the author.        }
{********************************************************************}

unit FMX.TMSBadge;

interface

{$I TMSDEFS.INC}

uses
  Classes, SysUtils, Types, UITypes, FMX.TMSHTMLText,
  FMX.Objects, FMX.Types, Math, FMX.TMSBaseControl, FMX.Controls
  {$IFDEF DELPHIXE5_LVL}
  , FMX.Graphics, FMX.Effects
  {$ENDIF}
  ;

const
  MAJ_VER = 1; // Major version nr.
  MIN_VER = 5; // Minor version nr.
  REL_VER = 0; // Release nr.
  BLD_VER = 0; // Build nr.

  // version history
  // v1.0.0.0 : first release
  // v1.0.0.1 : Improved : TMSIOS define
  // v1.5.0.0 : New : support for XE4


type
  [ComponentPlatformsAttribute(TMSPlatforms)]
  TTMSFMXBadge = class(TTMSFMXBaseControl)
  private
    FText: String;
    FAutoSize: Boolean;
    procedure SetText(const Value: String);
    procedure SetAutoSize(const Value: Boolean);
    function GetVersion: String;
    function GetVersionNr: Integer;
    procedure SetVersion(const Value: String);
  protected
    procedure ApplyStyle; override;
    function GetInstance: NativeUInt; override;
    procedure UpdateBadge;
  public
    constructor Create(AOwner: TComponent); override;
    function GetContent: TControl;
    function GetText: TControl;
    function GetShadow: TEffect;
  published
    property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
    property Text: String read FText write SetText;
    property Version: String read GetVersion write SetVersion;
  end;

implementation

{$R FMX.TMSBadge.res}

procedure TTMSFMXBadge.ApplyStyle;
begin
  inherited;
  UpdateBadge;
end;

constructor TTMSFMXBadge.Create(AOwner: TComponent);
begin
  inherited;
  FAutoSize := True;
  Width := 27;
  Height := 27;
end;

function TTMSFMXBadge.GetContent: TControl;
var
  obj: TFMXObject;
begin
  Result := nil;
  obj := FindStyleResource('badge');
  if Assigned(obj) and (obj is TControl) then
    Result := obj as TControl;
end;

function TTMSFMXBadge.GetInstance: NativeUInt;
begin
  Result := HInstance;
end;

function TTMSFMXBadge.GetShadow: TEffect;
var
  obj: TFMXObject;
begin
  Result := nil;
  obj := FindStyleResource('shadow');
  if Assigned(obj) and (obj is TEffect) then
    Result := obj as TEffect;
end;

function TTMSFMXBadge.GetText: TControl;
var
  obj: TFMXObject;
begin
  Result := nil;
  obj := FindStyleResource('text');
  if Assigned(obj) and (obj is TControl) then
    Result := obj as TControl;
end;

function TTMSFMXBadge.GetVersion: String;
var
  vn: Integer;
begin
  vn := GetVersionNr;
  Result := IntToStr(Hi(Hiword(vn)))+'.'+IntToStr(Lo(Hiword(vn)))+'.'+IntToStr(Hi(Loword(vn)))+'.'+IntToStr(Lo(Loword(vn)));
end;

function TTMSFMXBadge.GetVersionNr: integer;
begin
  Result := MakeLong(MakeWord(BLD_VER,REL_VER),MakeWord(MIN_VER,MAJ_VER));
end;

procedure TTMSFMXBadge.SetAutoSize(const Value: Boolean);
begin
  if FAutoSize <> Value then
  begin
    FAutoSize := Value;
    UpdateBadge;
  end;
end;

procedure TTMSFMXBadge.SetText(const Value: String);
begin
  if FText <> Value then
  begin
    FText := Value;
    UpdateBadge;
  end;
end;

procedure TTMSFMXBadge.SetVersion(const Value: String);
begin

end;

procedure TTMSFMXBadge.UpdateBadge;
var
  obj: TFmxObject;
  txt, t: TText;
  w, h: Single;
begin
  obj := FindStyleResource('text');
  if Assigned(obj) and (obj is TText) then
  begin
    txt := (obj as TText);
    txt.Text := Text;
    if AutoSize and (Text <> '') then
    begin
      t := TText.Create(Self);
      t.WordWrap := txt.WordWrap;
      t.AutoSize := True;
      t.Font.Assign(txt.Font);
      t.Text := Text;
      w := t.Width;
      h := t.Height;
      t.Free;
      Width := Max(27, w + txt.Margins.Left + txt.Margins.Right + 10);
      Height := Max(27, h + txt.Margins.Top + txt.Margins.Bottom);
    end;
  end;
end;

initialization
  RegisterFmxClasses([TTMSFMXBadge]);

end.
