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

interface

{$I TMSDEFS.INC}

uses
  Classes, Types, SysUtils, FMX.Types, FMX.Objects, UITypes,
  FMX.Dialogs, FMX.TMSHTMLEngine, FMX.TMSBitmapContainer, FMX.TMSBaseControl
  , UIConsts, FMX.Styles, FMX.Controls
  {$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 : Fixed : Issue with HTMLEngine prefixes in iOS
  //          : Reorganized packages
  // v1.1.1.0 : New : support for update 4
  // v1.1.1.1 : Improved : TMSIOS define
  //          : Fixed : Issue with Opacity in HTML Drawing
  // v1.1.1.2 : New : support for update 4 hotfix 1
  // v1.1.1.3 : Fixed : Issue with text  initialization in constructor
  // v1.1.1.4 : Fixed : Issue with text repainting at runtime
  //          : Fixed : Issue with text fill color initialization
  // v1.5.0.0 : New : support for XE4
  // v1.5.0.1 : Improved : GetTextHeight function

type
  TTMSFMXHTMLTextAnchorClickEvent = procedure(Sender: TObject; AAnchor: string) of object;

  [ComponentPlatformsAttribute(TMSPlatforms)]
  TTMSFMXHTMLText = class(TText)
  private
    FFill: TBrush;
    FStroke: TStrokeBrush;
    FBitmapContainer: TTMSFMXBitmapContainer;
    FOnAnchorClick: TTMSFMXHTMLTextAnchorClickEvent;
    FURLColor: TAlphaColor;
    FShadowOffset: integer;
    FShadowColor: TAlphaColor;
    function GetVersion: string;
    function GetVersionNr: Integer;
    procedure SetVersion(const Value: string);
    procedure SetShadowOffset(const Value: integer);
    procedure SetURLColor(const Value: TAlphaColor);
    procedure SetShadowColor(const Value: TAlphaColor);
    procedure SetBitmapContainer(const Value: TTMSFMXBitmapContainer);
    function GetText: String;
    procedure SetText(const Value: String);
    procedure SetFill(const Value: TBrush);
    procedure SetStroke(const Value: TStrokeBrush);
  protected
    procedure FillChanged(Sender: TObject);
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
    procedure DoAnchorClick(Anchor: string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
    function GetTextWidth: Single;
    function GetTextHeight: Single;
    function GetStrippedHTMLText: String;
    procedure DoMouseMove(Shift: TShiftState; X, Y: Single);
    procedure DoMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    procedure HTMLDraw(TestAnchor: boolean; X,Y: single; var Anchor:string);
    function IsHTML: boolean;
  published
    property Text: String read GetText write SetText;
    property BitmapContainer: TTMSFMXBitmapContainer read FBitmapContainer write SetBitmapContainer;
    property ShadowColor: TAlphaColor read FShadowColor write SetShadowColor default claGray;
    property ShadowOffset: integer read FShadowOffset write SetShadowOffset default 1;
    property URLColor: TAlphaColor read FURLColor write SetURLColor default claBlue;
    property Fill: TBrush read FFill write SetFill;
    property Stroke: TStrokeBrush read FStroke write SetStroke;

    property Version: String read GetVersion write SetVersion;
    property OnAnchorClick: TTMSFMXHTMLTextAnchorClickEvent read FOnAnchorClick write FOnAnchorClick;
  end;

implementation

constructor TTMSFMXHTMLText.Create(AOwner: TComponent);
var
  FDesignTime: boolean;
begin
  inherited;

  FDesignTime := (csDesigning in ComponentState) and not
                 ((csReading in Owner.ComponentState) or (csLoading in Owner.ComponentState));

  if FDesignTime then
    Text := 'TTMSFMXHTMLText';

  FURLColor := claBlue;
  FShadowOffset := 1;
  FShadowColor := claGray;
  {$IFDEF DELPHIXE6_LVL}
  FFill := TBrush.Create(TBrushKind.Solid, TAlphaColorRec.Black);
  FStroke := TStrokeBrush.Create(TBrushKind.Solid, $FF000000);
  {$ELSE}
  FFill := TBrush.Create(TBrushKind.bkSolid, TAlphaColorRec.Black);
  FStroke := TStrokeBrush.Create(TBrushKind.bkSolid, $FF000000);
  {$ENDIF}
  FFill.OnChanged := FillChanged;
end;

destructor TTMSFMXHTMLText.Destroy;
begin
  FFill.Free;
  FStroke.Free;
  inherited;
end;

procedure TTMSFMXHTMLText.DoAnchorClick(Anchor: string);
begin
  if Assigned(OnAnchorClick) then
    OnAnchorClick(Self, Anchor);
end;

procedure TTMSFMXHTMLText.DoMouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Single);
var
  Anchor: String;
begin
  if IsHTML then
  begin
    HTMLDraw(True, X, Y, Anchor);
    if Anchor <> '' then
      DoAnchorClick(Anchor);
  end;
end;

procedure TTMSFMXHTMLText.DoMouseMove(Shift: TShiftState; X, Y: Single);
var
  Anchor: string;
begin
  inherited;
  if IsHTML then
  begin
    HTMLDraw(True, X, Y, Anchor);
    if (Anchor <> '') then
      Cursor := crHandPoint
    else
      Cursor := crDefault;
  end;
end;

procedure TTMSFMXHTMLText.FillChanged(Sender: TObject);
begin
  Color := Fill.Color;
end;

function TTMSFMXHTMLText.GetStrippedHTMLText: String;
var
  r: TRectF;
  a, s, fa: String;
  XSize, YSize: Single;
  hl, ml: Integer;
  hr: TRectF;
  str: String;
begin
  str := Text;
  r := BoundsRect;
  if IsHTML then
  begin
    HTMLDrawEx(Canvas,str, r,0,0,-1,-1,ShadowOffset,False,True,False,False,False,False,WordWrap,1.0,URLColor,
      claNull,claNull,ShadowColor,a,s,fa,XSize,YSize,hl,ml,hr,0, BitmapContainer, AbsoluteOpacity);
    Result := s;
  end
  else
    Result := str;
end;

function TTMSFMXHTMLText.GetText: String;
begin
  Result := inherited Text;
end;

function TTMSFMXHTMLText.GetTextHeight: Single;
var
  r: TRectF;
  a, s, fa: String;
  XSize, YSize: Single;
  hl, ml: Integer;
  hr: TRectF;
  str: String;
begin
  str := Text;
  Canvas.Font.Assign(Font);
  r := BoundsRect;
  if IsHTML then
  begin
    HTMLDrawEx(Canvas,str, r,0,0,-1,-1,ShadowOffset,False,True,False,False,False,False,WordWrap,1.0,URLColor,
      claNull,claNull,ShadowColor,a,s,fa,XSize,YSize,hl,ml,hr,0, BitmapContainer, AbsoluteOpacity);
    Result := YSize;
  end
  else
    Result := Canvas.TextHeight(str);
end;

function TTMSFMXHTMLText.GetTextWidth: Single;
var
  r: TRectF;
  a, s, fa: String;
  XSize, YSize: Single;
  hl, ml: Integer;
  hr: TRectF;
  str: String;
begin
  str := Text;
  Canvas.Font.Assign(Font);
  r := BoundsRect;
  if IsHTML then
  begin
    HTMLDrawEx(Canvas,str, r,0,0,-1,-1,ShadowOffset,False,True,False,False,False,False,WordWrap,1.0,URLColor,
      claNull,claNull,ShadowColor,a,s,fa,XSize,YSize,hl,ml,hr,0, BitmapContainer, AbsoluteOpacity);
    Result := XSize;
  end
  else
    Result := Canvas.TextWidth(str);
end;

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

procedure TTMSFMXHTMLText.HTMLDraw(TestAnchor: boolean; X,Y: single; var Anchor: string);
var
  a, s, fa: String;
  XSize, YSize: Single;
  hl, ml: Integer;
  hr: TRectF;
  r: TRectF;
begin
  Canvas.Font.Assign(Font);
  Canvas.Fill.Assign(Fill);
  Canvas.Stroke.Assign(Stroke);
  r := BoundsRect;
  HTMLDrawEx(Canvas,Text, r,0,0,-1,-1,ShadowOffset,False,True,False,False,False,False,WordWrap,1.0,URLColor,
    claNull,claNull,ShadowColor,a,s,fa,XSize,YSize,hl,ml,hr,0, BitmapContainer, AbsoluteOpacity);

  {$IFDEF DELPHIXE6_LVL}
  case VertTextAlign of
    TTextAlign.Center: r.Top := r.Top + (r.Height - YSize) / 2;
    TTextAlign.Trailing: r.Top := r.Top + r.Height - YSize;
  end;

  case HorzTextAlign of
    TTextAlign.Center: r.Left := r.Left + (r.Width - XSize) / 2;
    TTextAlign.Trailing: r.Left := r.Left + r.Width - XSize;
  end;
  {$ELSE}
  case VertTextAlign of
    TTextAlign.taCenter: r.Top := r.Top + (r.Height - YSize) / 2;
    TTextAlign.taTrailing: r.Top := r.Top + r.Height - YSize;
  end;

  case HorzTextAlign of
    TTextAlign.taCenter: r.Left := r.Left + (r.Width - XSize) / 2;
    TTextAlign.taTrailing: r.Left := r.Left + r.Width - XSize;
  end;
  {$ENDIF}

  HTMLDrawEx(Canvas,Text, r, round(X) , round(Y) ,-1,-1,ShadowOffset,TestAnchor,False,False,False,False,False,WordWrap,1.0,URLColor,
    claNull,claNull,ShadowColor,a,s,fa,XSize,YSize,hl,ml,hr,0, BitmapContainer, AbsoluteOpacity);

  Anchor := a;
end;

function TTMSFMXHTMLText.IsHTML: boolean;
begin
  Result := (AnsiPos('</', Text) > 0) or (AnsiPos('/>', Text)  > 0) or (AnsiPos('<BR>', UpperCase(Text)) > 0);
end;

procedure TTMSFMXHTMLText.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Single);
begin
  inherited;
  DoMouseDown(Button, Shift, X, Y);
end;

procedure TTMSFMXHTMLText.MouseMove(Shift: TShiftState; X, Y: Single);
begin
  inherited;
  DoMouseMove(Shift, X, Y);
end;

procedure TTMSFMXHTMLText.SetBitmapContainer(
  const Value: TTMSFMXBitmapContainer);
begin
  FBitmapContainer := Value;
end;

procedure TTMSFMXHTMLText.SetFill(const Value: TBrush);
begin
  FFill.Assign(Value);
end;

procedure TTMSFMXHTMLText.SetShadowColor(const Value: TAlphaColor);
begin
  if (FShadowColor <> Value) then
  begin
    FShadowColor := Value;
    Repaint;
  end;
end;

procedure TTMSFMXHTMLText.SetShadowOffset(const Value: integer);
begin
  if (FShadowOffset <> Value) then
  begin
    FShadowOffset := Value;
    Repaint;
  end;
end;

procedure TTMSFMXHTMLText.SetText(const Value: String);
begin
  inherited Text := Value;
  Repaint;
end;

procedure TTMSFMXHTMLText.SetStroke(const Value: TStrokeBrush);
begin
  FStroke.Assign(Value);
end;

procedure TTMSFMXHTMLText.SetURLColor(const Value: TAlphaColor);
begin
  if (FURLColor <> Value) then
  begin
    FURLColor := Value;
    Repaint;
  end;
end;

procedure TTMSFMXHTMLText.SetVersion(const Value: string);
begin

end;

{ TTMSFMXHTMLText }

procedure TTMSFMXHTMLText.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if (Operation = opRemove) and (AComponent = FBitmapContainer) then
    FBitmapContainer := nil;
end;

procedure TTMSFMXHTMLText.Paint;
var
  str: String;
begin
  if IsHTML then
    HTMLDraw(false,-1,-1,str)
  else
    inherited;
end;

initialization
  RegisterFmxClasses([TTMSFMXHTMLText]);

end.
