{********************************************************************}
{                                                                    }
{ 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.TMSBarButton;

interface

{$I TMSDEFS.INC}

uses
  Classes, Types, SysUtils, FMX.Dialogs, FMX.Controls, UITypes, FMX.TMSBaseControl,
  FMX.Ani, FMX.Effects, FMX.Types, FMX.Objects, FMX.Layouts, FMX.TMSBitmap,
  FMX.TMSBitmapContainer, FMX.TMSHTMLText, FMX.StdCtrls, UIConsts, FMX.Styles
  {$IFDEF DELPHIXE5_LVL}
  , FMX.Graphics
  {$ENDIF}
  ;

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

  // version history
  // v1.0.0.0 : First Release
  // v1.1.0.3 : Support for TTMSFMXBitmap
  //          : Fixed : Small issue with loading styles
  //          : Reorganized packages
  // v1.1.1.0 : New : support for update 4
  // v1.1.2.0 : New : HTML support
  //          : Improved : TMSIOS define
  // v1.1.2.1 : New : support for update 4 hotfix 1
  // v1.1.3.0 : New : Pointer direction property
  // v1.5.0.0 : New : support for XE4
  // v1.5.0.1 : Fixed : Issue with ShowImage


type
  TTMSFMXBarButtonKind = (bkNormal, bkDone, bkEdit, bkCancel, bkMove, bkArchive, bkDelete, bkMark, bkBack);

  TTMSFMXBarButtonShapeLayout = (slRectangle, slPointer);
  TTMSFMXBarButtonShapeDirection = (sdLeft, sdRight);

  TTMSFMXBarButtonShape = class(TRectangle)
  private
    FLayout: TTMSFMXBarButtonShapeLayout;
    FDirection: TTMSFMXBarButtonShapeDirection;
    procedure SetLayout(const Value: TTMSFMXBarButtonShapeLayout);
    procedure SetDirection(const Value: TTMSFMXBarButtonShapeDirection);
  public
    procedure Paint; override;
    constructor Create(AOwner: TComponent); override;
  published
    property Layout: TTMSFMXBarButtonShapeLayout read FLayout write SetLayout default slRectangle;
    property Direction: TTMSFMXBarButtonShapeDirection read FDirection write SetDirection default sdLeft;
  end;

  [ComponentPlatformsAttribute(TMSPlatforms)]
  TTMSFMXBarButton = class(TButton)
  private
    FLayout: TTMSFMXBarButtonShapeLayout;
    FKind: TTMSFMXBarButtonKind;
    FAllowCustomize: Boolean;
    FShowImage: Boolean;
    FBitmapContainer: TTMSFMXBitmapContainer;
    FBitmap: TBitmap;
    FBitmapName: String;
    FLinkedImage: TImage;
    FShowText: Boolean;
    FDirection: TTMSFMXBarButtonShapeDirection;
    procedure SetKind(const Value: TTMSFMXBarButtonKind);
    function GetLayout: TTMSFMXBarButtonShapeLayout;
    procedure SetLayout(const Value: TTMSFMXBarButtonShapeLayout);
    procedure SetAllowCustomize(const Value: Boolean);
    procedure SetBitmap(const Value: TBitmap);
    procedure SetBitmapContainer(const Value: TTMSFMXBitmapContainer);
    procedure SetBitmapName(const Value: String);
    procedure SetLinkedImage(const Value: TImage);
    procedure SetShowImage(const Value: Boolean);
    function GetVersion: String;
    function GetVersionNr: Integer;
    procedure SetVersion(const Value: String);
    procedure SetShowText(const Value: Boolean);
    procedure SetDirection(const Value: TTMSFMXBarButtonShapeDirection);
  protected
    procedure BitmapChanged(Sender: TObject);
    procedure UpdateButtonKind;
    procedure UpdateButtonLayout;
    function GetClassName: String; virtual;
    function GetClassStyleName: String; virtual;
    procedure ApplyStyle; override;
    function GetStyleObject: TFMXObject; override;
    function LoadFromResource: TFMXObject;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetBackGround: TRectangle;
    function GetImage: TTMSFMXBitmap;
    function GetContents: TRectangle;
    function GetColorAnimationIn: TColorAnimation;
    function GetColorAnimationOut: TColorAnimation;
    function GetInnerGlowEffect: TInnerGlowEffect;
    function GetInnerBorder: TRectangle;
    function GetText: TText;
    function GetOuterGlow: TGlowEffect;
  published
    property Text;
    property AllowCustomize: Boolean read FAllowCustomize write SetAllowCustomize default True;
    property Kind: TTMSFMXBarButtonKind read FKind write SetKind default bkNormal;
    property Layout: TTMSFMXBarButtonShapeLayout read GetLayout write SetLayout default slRectangle;
    property Direction: TTMSFMXBarButtonShapeDirection read FDirection write SetDirection default sdLeft;
    property BitmapContainer: TTMSFMXBitmapContainer read FBitmapContainer write SetBitmapContainer;
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property BitmapName: String read FBitmapName write SetBitmapName;
    property ShowImage: Boolean read FShowImage write SetShowImage default False;
    property ShowText: Boolean read FShowText write SetShowText default True;
    property LinkedImage: TImage read FLinkedImage write SetLinkedImage;
    property Version: String read GetVersion write SetVersion;
  end;

implementation

{$R FMX.TMSBarButton.res}

{ TTMSFMXBarButton }

procedure TTMSFMXBarButton.ApplyStyle;
var
  shp: TTMSFMXBitmap;
  shptxt: TText;
begin
  inherited;
  if not AllowCustomize then
  begin
    UpdateButtonKind;
    UpdateButtonLayout;
  end;

  shp := GetImage;
  if Assigned(shp) then
  begin
    shp.Visible := ShowImage;
    shp.BitmapName := BitmapName;
    shp.Bitmap.Assign(Bitmap);
    shp.BitmapContainer := BitmapContainer;
    shp.LinkedImage := LinkedImage;
  end;

  shptxt := GetText;
  if Assigned(shptxt) then
    shptxt.Visible := ShowText;
end;

procedure TTMSFMXBarButton.BitmapChanged(Sender: TObject);
var
  shp: TTMSFMXBitmap;
begin
  shp := GetImage;
  if Assigned(shp) then
    shp.Bitmap.Assign(Bitmap);
end;

constructor TTMSFMXBarButton.Create(AOwner: TComponent);
begin
  inherited;
  FAllowCustomize := True;
  Width := 113;
  Height := 30;
  FLayout := slRectangle;
  FDirection := sdLeft;
  FKind := bkNormal;
  FShowImage := False;
  FShowText := True;
  FBitmap := TBitmap.Create(0, 0);
  FBitmap.OnChange := BitmapChanged;
end;

destructor TTMSFMXBarButton.Destroy;
begin
  FBitmap.Free;
  inherited;
end;

function TTMSFMXBarButton.GetBackGround: TRectangle;
begin
  Result := FindStyleResource('background') as TRectangle;
end;

function TTMSFMXBarButton.GetClassName: String;
begin
  Result := ClassName;
end;

function TTMSFMXBarButton.GetClassStyleName: String;
begin
  Result := GetClassName + 'style';
  Delete(Result, 1, 1);
end;

function TTMSFMXBarButton.GetColorAnimationIn: TColorAnimation;
var
  bkg: TRectangle;
begin
  Result := nil;
  bkg := GetBackGround;
  if Assigned(bkg) then
    Result := bkg.FindStyleResource('coloranimationin') as TColorAnimation;
end;

function TTMSFMXBarButton.GetColorAnimationOut: TColorAnimation;
var
  bkg: TRectangle;
begin
  Result := nil;
  bkg := GetBackGround;
  if Assigned(bkg) then
    Result := bkg.FindStyleResource('coloranimationout') as TColorAnimation;
end;

function TTMSFMXBarButton.GetContents: TRectangle;
var
  bkg: TRectangle;
begin
  Result := nil;
  bkg := GetBackGround;
  if Assigned(bkg) then
    Result := bkg.FindStyleResource('contents') as TRectangle;
end;

function TTMSFMXBarButton.GetImage: TTMSFMXBitmap;
begin
  Result := FindStyleResource('image') as TTMSFMXBitmap;
end;

function TTMSFMXBarButton.GetInnerBorder: TRectangle;
var
  bkg: TRectangle;
begin
  Result := nil;
  bkg := GetBackGround;
  if Assigned(bkg) then
    Result := bkg.FindStyleResource('innerborder') as TRectangle;
end;

function TTMSFMXBarButton.GetInnerGlowEffect: TInnerGlowEffect;
var
  bkg: TRectangle;
begin
  Result := nil;
  bkg := GetBackGround;
  if Assigned(bkg) then
    Result := bkg.FindStyleResource('innergloweffect') as TInnerGlowEffect;
end;

function TTMSFMXBarButton.GetLayout: TTMSFMXBarButtonShapeLayout;
begin
  Result := FLayout;
end;

function TTMSFMXBarButton.GetOuterGlow: TGlowEffect;
begin
  Result := FindStyleResource('outergloweffect') as TGlowEffect;
end;

function TTMSFMXBarButton.GetStyleObject: TFMXObject;
var
  obj: TFMXObject;
begin
  obj := inherited GetStyleObject;
  if not (csDestroying in ComponentState) then
  begin
    if Assigned(obj) and (obj.ClassType = TLayout) then
    begin
      obj.Free;
      obj := LoadFromResource;
    end;
  end;

  Result := obj;
end;

function TTMSFMXBarButton.GetText: TText;
begin
  Result := FindStyleResource('text') as TText;
end;

function TTMSFMXBarButton.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 TTMSFMXBarButton.GetVersionNr: integer;
begin
  Result := MakeLong(MakeWord(BLD_VER,REL_VER),MakeWord(MIN_VER,MAJ_VER));
end;

function TTMSFMXBarButton.LoadFromResource: TFMXObject;
var
  str: String;
begin
  Result := nil;
  // create resource class name
  str := GetClassStyleName;
  if FindRCData(HInstance, str) then
    {$IFDEF DELPHIXE6_LVL}
    Result := TStyleStreaming.LoadFromResource(HInstance, str, RT_RCDATA);
    {$ELSE}
    Result := TStyleManager.LoadFromResource(HInstance, str, RT_RCDATA);
    {$ENDIF}
end;

procedure TTMSFMXBarButton.SetAllowCustomize(const Value: Boolean);
begin
  if FAllowCustomize <> Value then
    FAllowCustomize := Value;
end;

procedure TTMSFMXBarButton.SetBitmap(const Value: TBitmap);
begin
  FBitmap.Assign(Value);
end;

procedure TTMSFMXBarButton.SetBitmapContainer(
  const Value: TTMSFMXBitmapContainer);
var
  shp: TTMSFMXBitmap;
begin
  FBitmapContainer := Value;
  shp := GetImage;
  if Assigned(shp) then
    shp.BitmapContainer := Value;
end;

procedure TTMSFMXBarButton.SetBitmapName(const Value: String);
var
  shp: TTMSFMXBitmap;
begin
  FBitmapName := Value;
  shp := GetImage;
  if Assigned(shp) then
    shp.BitmapName := Value;
end;

procedure TTMSFMXBarButton.SetDirection(
  const Value: TTMSFMXBarButtonShapeDirection);
begin
  FDirection := Value;
  UpdateButtonLayout;
end;

procedure TTMSFMXBarButton.SetKind(
  const Value: TTMSFMXBarButtonKind);
begin
  FKind := Value;
  UpdateButtonKind;
end;

procedure TTMSFMXBarButton.SetLayout(
  const Value: TTMSFMXBarButtonShapeLayout);
begin
  FLayout := Value;
  UpdateButtonLayout;
end;

procedure TTMSFMXBarButton.SetLinkedImage(const Value: TImage);
var
  shp: TTMSFMXBitmap;
begin
  FLinkedImage := Value;
  shp := GetImage;
  if Assigned(shp) then
    shp.LinkedImage := Value;
end;

procedure TTMSFMXBarButton.SetShowImage(const Value: Boolean);
var
  shp: TTMSFMXBitmap;
begin
  FShowImage := Value;
  shp := GetImage;
  if Assigned(shp) then
    shp.Visible := Value;
end;

procedure TTMSFMXBarButton.SetShowText(const Value: Boolean);
var
  shp: TText;
begin
  FShowText := Value;
  shp := GetText;
  if Assigned(shp) then
    shp.Visible := Value;
end;

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

end;

procedure TTMSFMXBarButton.UpdateButtonLayout;
var
  innerborder, cnt, bkg: TRectangle;
begin
  bkg := GetBackGround;
  cnt := GetContents;
  innerborder := GetInnerBorder;

  if Assigned(bkg) and Assigned(cnt) and Assigned(innerborder) then
  begin
    (bkg as TTMSFMXBarButtonShape).Layout := Layout;
    (cnt as TTMSFMXBarButtonShape).Layout := Layout;
    (bkg as TTMSFMXBarButtonShape).Direction := Direction;
    (cnt as TTMSFMXBarButtonShape).Direction := Direction;
    (innerborder as TTMSFMXBarButtonShape).Layout := Layout;
    (innerborder as TTMSFMXBarButtonShape).Direction := Direction;
  end;
end;

procedure TTMSFMXBarButton.UpdateButtonKind;
var
  cnt, bkg: TRectangle;
  colorin, colorout: TColorAnimation;
  innergloweffect: TInnerGlowEffect;
  innerborder: TRectangle;
  outerglow: TGlowEffect;
  c, cto, cm, cmto, bc: TAlphaColor;
begin
  bkg := GetBackGround;
  cnt := GetContents;
  colorin := GetColorAnimationIn;
  colorout := GetColorAnimationOut;
  innergloweffect := GetInnerGlowEffect;
  innerborder := GetInnerBorder;
  outerglow := GetOuterGlow;

  if Assigned(bkg) and Assigned(cnt) and Assigned(colorin) and Assigned(colorout)
    and Assigned(innergloweffect) and Assigned(innerborder) and Assigned(outerglow) then
  begin
    c :=  MakeColor(175,179,185);
    cto := MakeColor(107,115,126);
    cm := c;
    cmto := cto;
    bc := MakeColor(86,91,100);
    case Kind of
      bkCancel, bkDone:
      begin
        c := MakeColor(140,173,236);
        cto := MakeColor(34,98,221);
        bc := MakeColor(26,78,178);
      end;
      bkMove, bkMark:
      begin
        c :=  MakeColor(142,164,193);
        cto := MakeColor(88,119,162);
        cm :=  MakeColor(71,105,153);
        cmto := cm;
        bc := MakeColor(53,79,115);
      end;
      bkArchive, bkDelete:
      begin
        c :=  MakeColor(219,131,137);
        cto := MakeColor(208,87,97);
        cm :=  MakeColor(189,20,33);
        cmto := cm;
        bc := MakeColor(118,13,21);
      end;
    end;

    case Kind of
      bkDelete, bkArchive, bkMove, bkMark:
      begin
        bkg.Fill.Gradient.Points.Clear;
        with (bkg.Fill.Gradient.Points.Add as TGradientPoint) do
        begin
          Color := c;
          Offset := 0;
        end;
        with (bkg.Fill.Gradient.Points.Add as TGradientPoint) do
        begin
          Color := cto;
          Offset := 0.5;
        end;
        with (bkg.Fill.Gradient.Points.Add as TGradientPoint) do
        begin
          Color := cm;
          Offset := 0.5;
        end;
        with (bkg.Fill.Gradient.Points.Add as TGradientPoint) do
        begin
          Color := cmto;
          Offset := 1;
        end;
        bkg.Stroke.Color := bc;
        cnt.Fill.Assign(bkg.Fill);
        cnt.Stroke.Assign(bkg.Stroke);
        colorin.StartValue := c;
        colorin.StopValue := cto;
        colorout.StartValue := cto;
        colorout.StopValue := c;
        innergloweffect.GlowColor := c;
        outerglow.GlowColor := c;
        innerborder.Stroke.Gradient.Points.Clear;

        with (innerborder.Stroke.Gradient.Points.Add as TGradientPoint) do
        begin
          Color := cmto;
          Offset := 1;
        end;
        with (innerborder.Stroke.Gradient.Points.Add as TGradientPoint) do
        begin
          Color := MakeColor(cm, 0);
          Offset := 0
        end;
      end
      else
      begin
        bkg.Fill.Gradient.Points.Clear;
        with (bkg.Fill.Gradient.Points.Add as TGradientPoint) do
        begin
          Color := c;
          Offset := 0;
        end;
        with (bkg.Fill.Gradient.Points.Add as TGradientPoint) do
        begin
          Color := cto;
          Offset := 1;
        end;
        bkg.Stroke.Color := bc;
        cnt.Fill.Assign(bkg.Fill);
        colorin.StartValue := c;
        colorin.StopValue := cto;
        colorout.StartValue := cto;
        colorout.StopValue := c;
        innergloweffect.GlowColor := c;
        outerglow.GlowColor := c;
        innerborder.Stroke.Gradient.Points.Clear;

        with (innerborder.Stroke.Gradient.Points.Add as TGradientPoint) do
        begin
          Color := cto;
          Offset := 1;
        end;
        with (innerborder.Stroke.Gradient.Points.Add as TGradientPoint) do
        begin
          Color := MakeColor(cto, 0);
          Offset := 0;
        end;
      end;
    end;

    case Kind of
      bkDone: Text := 'Done';
      bkCancel: Text := 'Cancel';
      bkEdit: Text := 'Edit';
      bkMove: Text := 'Move';
      bkArchive: Text := 'Archive';
      bkBack: Text := 'Back';
      bkDelete: Text := 'Delete';
      bkMark: Text := 'Mark';
    end;

    case Kind of
      bkBack:Layout := slPointer;
      else
        Layout := slRectangle;
    end;
  end;
end;


{ TTMSFMXBarButtonShape }

constructor TTMSFMXBarButtonShape.Create(AOwner: TComponent);
begin
  inherited;
  FLayout := slRectangle;
  FDirection := sdLeft;
end;

procedure TTMSFMXBarButtonShape.Paint;
var
  pth: TPathData;
begin
  case Layout of
    slRectangle: inherited;
    slPointer:
    begin
      pth := TPathData.Create;
      case Direction of
        sdLeft:
        begin
          pth.MoveTo(PointF(0, Height / 2));
          pth.LineTo(PointF(10, 0));
          pth.LineTo(PointF(Width - XRadius, 0));
          pth.AddArc(PointF(Width - XRadius, YRadius), PointF(XRadius, YRadius),-90, 90);
          pth.LineTo(PointF(Width, Height - YRadius));
          pth.AddArc(PointF(Width - XRadius, Height - YRadius), PointF(XRadius, YRadius),0, 90);
          pth.LineTo(PointF(10, Height));
        end;
        sdRight:
        begin
          pth.MoveTo(PointF(Width, Height / 2));
          pth.LineTo(PointF(Width - 10, Height));
          pth.LineTo(PointF(XRadius, Height));
          pth.AddArc(PointF(XRadius, Height - YRadius), PointF(XRadius, YRadius),90, 90);
          pth.LineTo(PointF(0, YRadius));
          pth.AddArc(PointF(XRadius, YRadius), PointF(XRadius, YRadius),180, 90);
          pth.LineTo(PointF(Width - 10, 0));
        end;
      end;
      pth.ClosePath;
      pth.Flatten;
      Canvas.FillPath(pth, AbsoluteOpacity, Fill);
      Canvas.DrawPath(pth, AbsoluteOpacity, Stroke);
      pth.Free;
    end;
  end;
end;

procedure TTMSFMXBarButtonShape.SetDirection(
  const Value: TTMSFMXBarButtonShapeDirection);
begin
  if FDirection <> Value then
  begin
    FDirection := Value;
    Repaint;
  end;
end;

procedure TTMSFMXBarButtonShape.SetLayout(
  const Value: TTMSFMXBarButtonShapeLayout);
begin
  if FLayout <> Value then
  begin
    FLayout := Value;
    Repaint;
  end;
end;

initialization
  RegisterFmxClasses([TTMSFMXBarButtonShape, TTMSFMXBarButton]);

end.
