FastReport_FMX_2.8.12/LibD28/FMX.frxGraphicUtils.pas

1705 lines
42 KiB
ObjectPascal
Raw Normal View History

2024-01-10 21:50:38 +01:00
{******************************************}
{ }
{ FastReport v4.0 }
{ Graphic routines }
{ }
{ Copyright (c) 1998-2011 }
{ by Alexander Tzyganenko, }
{ Fast Reports Inc. }
{ }
{******************************************}
unit FMX.frxGraphicUtils;
interface
{$I fmx.inc}
{$I frx.inc}
uses
System.SysUtils, System.Classes, System.UITypes, System.UIConsts, System.StrUtils,
System.WideStrings, System.Types, System.Variants, System.Generics.Collections,
System.Math, FMX.Types, FMX.Forms,
FMX.frxFMX, FMX.frxClass
{$IFDEF DELPHI19}
, FMX.Graphics
{$ENDIF}
{$IFDEF DELPHI20}
, System.Math.Vectors
{$ENDIF}
{$IFDEF DELPHI28}
, FMX.BaseTypeAliases
{$ENDIF};
type
TBaseLine = (Normal, Subscript, Superscript);
TStyleDescriptor = record
FontStyle: TFontStyles;
Color: TAlphaColor;
BaseLine: TBaseLine;
end;
TParagraph = class;
TLine = class;
TWord = class;
TRun = class;
TSubStyle = (ssNormal, ssSubscript, ssSuperscript);
TfrxHTMLTag = class(TObject)
public
Position: Integer;
Size: Integer;
AddY: Integer;
Style: TFontStyles;
Color: TAlphaColor;
Default: Boolean;
Small: Boolean;
DontWRAP: Boolean;
SubType: TSubStyle;
procedure Assign(Tag: TfrxHTMLTag);
end;
TfrxHTMLTags = class(TObject)
private
FItems: TList;
procedure Add(Tag: TfrxHTMLTag);
function GetItems(Index: Integer): TfrxHTMLTag;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
function Count: Integer;
property Items[Index: Integer]: TfrxHTMLTag read GetItems; default;
end;
TfrxHTMLTagsList = class(TObject)
private
FAllowTags: Boolean;
FAddY: Integer;
FColor: Integer;
FDefColor: LongInt;
FDefSize: Integer;
FDefStyle: TFontStyles;
FItems: TList;
FPosition: Integer;
FSize: Integer;
FStyle: TFontStyles;
FDontWRAP: Boolean;
FSubStyle: TSubStyle;
procedure NewLine;
function Add: TfrxHTMLTag;
function GetItems(Index: Integer): TfrxHTMLTags;
function GetPrevTag: TfrxHTMLTag;
protected
procedure Wrap(TagsCount: Integer; AddBreak: Boolean);
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure SetDefaults(DefColor: TColor; DefSize: Integer;
DefStyle: TFontStyles);
procedure ExpandHTMLTags(var s: WideString);
function Count: Integer;
property AllowTags: Boolean read FAllowTags write FAllowTags;
property Items[Index: Integer]: TfrxHTMLTags read GetItems; default;
property Position: Integer read FPosition write FPosition;
end;
TAdvancedTextRenderer = class
private
FParagraphs: TList<TParagraph>;
FText: String;
FCanvas: TCanvas;
FFont: TfrxFont;
FDisplayRect: TRectF;
FHorzAlign: TfrxHAlign;
FVertAlign: TfrxVAlign;
FLineHeight: Single;
FFontLineHeight: Single;
FAngle: Integer;
FForceJustify: Boolean;
FWysiwyg: Boolean;
FHtmlTags: Boolean;
FWordWrap: Boolean;
FRightToLeft: Boolean;
FPDFMode: Boolean;
FSpaceWidth: Single;
FSymbolWidth: Single;
FScaleFactor: Single;
FFastRender: TfrxFastCanvasLayer;
procedure SplitToParagraphs(const text: String);
procedure AdjustParagraphLines;
public
constructor Create(aCanvas: TCanvas; const aText: String; aFont: TfrxFont; rect: TRectF;
aHorzAlign: TfrxHAlign; aVertAlign: TfrxVAlign; aLineHeight: Single; aAngle: Integer;
aWordWrap: Boolean; aForceJustify: Boolean; aHtmlTags: Boolean; aPdfMode: Boolean; aScaLeFactor: Single);
destructor Destroy; override;
function CalcWidth: Single;
function MeasureTextWidth(const aText: String): Single;
function CalcHeight: Single; overload;
function CalcHeight(var charsFit: Integer; var style: TStyleDescriptor): Single; overload;
function GetTabPosition(pos: Single): Single;
procedure Draw;
property Paragraphs: TList<TParagraph> read FParagraphs;
property Canvas: TCanvas read FCanvas;
property Font: TfrxFont read FFont;
property DisplayRect: TRectF read FDisplayRect;
property HorzAlign: TfrxHAlign read FHorzAlign;
property VertAlign: TfrxVAlign read FVertAlign;
property LineHeight: Single read FLineHeight;
property FontLineHeight: Single read FFontLineHeight;
property Angle: Integer read FAngle;
property ForceJustify: Boolean read FForceJustify;
property Wysiwyg: Boolean read FWysiwyg;
property HtmlTags: Boolean read FHtmlTags;
property WordWrap: Boolean read FWordWrap;
property RightToLeft: Boolean read FRightToLeft;
property PDFMode: Boolean read FPDFMode;
property SpaceWidth: Single read FSpaceWidth;
property SymbolWidth: Single read FSymbolWidth;
end;
TParagraph = class
private
FLines: TList<TLine>;
FRenderer: TAdvancedTextRenderer;
FText: String;
FOriginalCharIndex: Integer;
public
constructor Create(const text: String; renderer: TAdvancedTextRenderer; originalCharIndex: Integer);
destructor Destroy; override;
function IsLast: Boolean;
function IsEmpty: Boolean;
function WrapLines(style: TStyleDescriptor): TStyleDescriptor;
procedure AlignLines(forceJustify: Boolean);
procedure Draw;
property Lines: TList<TLine> read FLines;
property Renderer: TAdvancedTextRenderer read FRenderer;
end;
TLine = class
private
FWords: TList<TWord>;
FParagraph: TParagraph;
FTop: Single;
FWidth: Single;
FOriginalCharIndex: Integer;
FUnderlines: TList<TRectF>;
FStrikeouts: TList<TRectF>;
function GetStyle: TStyleDescriptor;
function GetRenderer: TAdvancedTextRenderer;
function GetLeft: Single;
procedure PrepareUnderlines(list: TList<TRectF>; style: TFontStyle);
function GetText: String;
public
constructor Create(paragraph: TParagraph; originalCharIndex: Integer);
destructor Destroy; override;
function IsLast: Boolean;
procedure AlignWords(align: TfrxHAlign);
procedure MakeUnderlines;
procedure Draw;
property Words: TList<TWord> read FWords;
property Left: Single read GetLeft;
property Top: Single read FTop write FTop;
property Width: Single read FWidth;
property Text: String read GetText;
property OriginalCharIndex: Integer read FOriginalCharIndex;
property Renderer: TAdvancedTextRenderer read GetRenderer;
property Style: TStyleDescriptor read GetStyle;
property Underlines: TList<TRectF> read FUnderlines;
property Strikeouts: TList<TRectF> read FStrikeouts;
end;
TWord = class
private
FRuns: TList<TRun>;
FLeft: Single;
FWidth: Single;
FLine: TLine;
function GetWidth: Single;
function GetTop: Single;
function GetRenderer: TAdvancedTextRenderer;
function GetText: String;
public
constructor Create(aLine: TLine);
destructor Destroy; override;
procedure AdjustRuns;
procedure SetLine(aLine: TLine);
procedure Draw;
property Left: Single read FLeft write FLeft;
property Width: Single read GetWidth;
property Top: Single read GetTop;
property Text: String read GetText;
property Renderer: TAdvancedTextRenderer read GetRenderer;
property Runs: TList<TRun> read FRuns;
end;
TTab = class(TWord);
TRun = class
private
FText: String;
FStyle: TStyleDescriptor;
FWord: TWord;
FLeft: Single;
FWidth: Single;
function GetRenderer: TAdvancedTextRenderer;
function GetTop: Single;
function GetFont(disableUnderlinesStrikeouts: Boolean): TfrxFont; overload;
public
constructor Create(const aText: String; aStyle: TStyleDescriptor; aWord: TWord);
function GetFont: TfrxFont; overload;
procedure Draw;
property Text: String read FText;
property Style: TStyleDescriptor read FStyle;
property Renderer: TAdvancedTextRenderer read GetRenderer;
property Left: Single read FLeft write FLeft;
property Top: Single read GetTop;
property Width: Single read FWidth;
end;
implementation
{ TStyleDescriptor routines }
function StyleDescriptor(FontStyle: TFontStyles; Color: TAlphaColor; BaseLine: TBaseLine): TStyleDescriptor;
begin
Result.FontStyle := FontStyle;
Result.Color := Color;
Result.BaseLine := BaseLine;
end;
function NullStyle: TStyleDescriptor;
begin
Result.FontStyle := [];
Result.Color := 0;
Result.BaseLine := TBaseLine.Normal;
end;
function StyleDescriptorToString(style: TStyleDescriptor): String;
begin
Result := '';
if fsBold in style.FontStyle then
Result := Result + '<b>';
if fsItalic in style.FontStyle then
Result := Result + '<i>';
if fsUnderline in style.FontStyle then
Result := Result + '<u>';
if fsStrikeout in style.FontStyle then
Result := Result + '<strike>';
if style.BaseLine = TBaseLine.Subscript then
Result := Result + '<sub>';
if style.BaseLine = TBaseLine.Superscript then
Result := Result + '<sup>';
Result := Result + '<font color="' + AlphaColorToString(style.Color) + '">';
end;
function AdjY(Value, Thickness: Single): Single;
begin
Result := Round(Value);
if (Trunc(Thickness) mod 2) = 1 then
Result := Result + 0.5;
end;
{ TfrxHTMLTag }
procedure TfrxHTMLTag.Assign(Tag: TfrxHTMLTag);
begin
Position := Tag.Position;
Size := Tag.Size;
AddY := Tag.AddY;
Style := Tag.Style;
Color := Tag.Color;
Default := Tag.Default;
Small := Tag.Small;
Self.SubType := Tag.SubType;
end;
{ TfrxHTMLTags }
constructor TfrxHTMLTags.Create;
begin
FItems := TList.Create;
end;
destructor TfrxHTMLTags.Destroy;
begin
Clear;
FItems.Free;
inherited;
end;
procedure TfrxHTMLTags.Clear;
var
i: Integer;
begin
for i := 0 to FItems.Count - 1 do
TfrxHTMLTag(FItems[i]).Free;
FItems.Clear;
end;
function TfrxHTMLTags.GetItems(Index: Integer): TfrxHTMLTag;
begin
Result := TfrxHTMLTag(FItems[Index]);
end;
function TfrxHTMLTags.Count: Integer;
begin
Result := FItems.Count;
end;
procedure TfrxHTMLTags.Add(Tag: TfrxHTMLTag);
begin
FItems.Add(Tag);
end;
{ TfrxHTMLTagsList }
constructor TfrxHTMLTagsList.Create;
begin
FItems := TList.Create;
FAllowTags := True;
end;
destructor TfrxHTMLTagsList.Destroy;
begin
Clear;
FItems.Free;
inherited;
end;
procedure TfrxHTMLTagsList.Clear;
var
i: Integer;
begin
for i := 0 to FItems.Count - 1 do
TfrxHTMLTags(FItems[i]).Free;
FItems.Clear;
end;
procedure TfrxHTMLTagsList.NewLine;
begin
if Count <> 0 then
FItems.Add(TfrxHTMLTags.Create);
end;
procedure TfrxHTMLTagsList.Wrap(TagsCount: Integer; AddBreak: Boolean);
var
i: Integer;
Line, OldLine: TfrxHTMLTags;
NewTag: TfrxHTMLTag;
begin
OldLine := Items[Count - 1];
if OldLine.Count <= TagsCount then
Exit;
NewLine;
Line := Items[Count - 1];
for i := TagsCount to OldLine.Count - 1 do
Line.Add(OldLine[i]);
OldLine.FItems.Count := TagsCount;
if AddBreak then
begin
NewTag := TfrxHTMLTag.Create;
OldLine.FItems.Add(NewTag);
NewTag.Assign(TfrxHTMLTag(OldLine.FItems[TagsCount - 1]))
end
else if Line[0].Default then
Line[0].Assign(OldLine[TagsCount - 1]);
end;
function TfrxHTMLTagsList.Count: Integer;
begin
Result := FItems.Count;
end;
function TfrxHTMLTagsList.GetItems(Index: Integer): TfrxHTMLTags;
begin
Result := TfrxHTMLTags(FItems[Index]);
end;
function TfrxHTMLTagsList.Add: TfrxHTMLTag;
var
i: Integer;
begin
Result := TfrxHTMLTag.Create;
i := Count - 1;
if i = -1 then
begin
FItems.Add(TfrxHTMLTags.Create);
i := 0;
end;
Items[i].Add(Result);
end;
function TfrxHTMLTagsList.GetPrevTag: TfrxHTMLTag;
var
Tags: TfrxHTMLTags;
begin
Result := nil;
Tags := Items[Count - 1];
if Tags.Count > 1 then
Result := Tags[Tags.Count - 2]
else if Count > 1 then
begin
Tags := Items[Count - 2];
Result := Tags[Tags.Count - 1];
end;
end;
procedure TfrxHTMLTagsList.SetDefaults(DefColor: TColor; DefSize: Integer;
DefStyle: TFontStyles);
begin
FDefColor := DefColor;
FDefSize := DefSize;
FDefStyle := DefStyle;
FAddY := 0;
FColor := FDefColor;
FSize := FDefSize;
FStyle := FDefStyle;
FDontWRAP := False;
FPosition := 1;
Self.FSubStyle := ssNormal;
Clear;
end;
procedure TfrxHTMLTagsList.ExpandHTMLTags(var s: WideString);
var
i, j, j1: Integer;
b: Boolean;
cl: WideString;
procedure AddTag;
var
Tag, PrevTag: TfrxHTMLTag;
begin
Tag := Add;
Tag.Position := FPosition; // this will help us to get position in the original text
Tag.Size := FSize;
Tag.Style := FStyle;
Tag.Color := FColor;
Tag.AddY := FAddY;
Tag.DontWRAP := FDontWRAP;
Tag.SubType := Self.FSubStyle;
// when "Default" changes, we need to set Font.Style, Size and Color
if FAllowTags then
begin
PrevTag := GetPrevTag;
if PrevTag <> nil then
Tag.Default := (FStyle = PrevTag.Style) and
(Cardinal(FColor) = PrevTag.Color) and
(FSize = PrevTag.Size) and (FAddY = PrevTag.AddY) and (FDontWRAP = PrevTag.DontWRAP)
else
Tag.Default := (FStyle = FDefStyle) and (FColor = FDefColor) and (FSize = FDefSize);
end
else
Tag.Default := True;
Tag.Small := FSize <> FDefSize;
end;
begin
i := 1;
if Length(s) = 0 then Exit;
while i <= Length(s) do
begin
b := True;
if FAllowTags then
if s[i] = '<' then
begin
// <b>, <u>, <i> tags
if (i + 2 <= Length(s)) and (s[i + 2] = '>') then
begin
case s[i + 1] of
'b','B': FStyle := FStyle + [fsBold];
'i','I': FStyle := FStyle + [fsItalic];
'u','U': FStyle := FStyle + [fsUnderline];
else
b := False;
end;
if b then
begin
System.Delete(s, i, 3);
Inc(FPosition, 3);
continue;
end;
end
// <sub>, <sup> tags
else if (i + 4 <= Length(s)) and (s[i + 4] = '>') then
begin
if Pos('SUB>', AnsiUpperCase(s)) = i + 1 then
begin
FSize := Round(FDefSize / 1.5);
FAddY := 1;
b := True;
Self.FSubStyle := ssSubscript;
end
else if Pos('SUP>', AnsiUpperCase(s)) = i + 1 then
begin
FSize := Round(FDefSize / 1.5);
FAddY := 0;
b := True;
Self.FSubStyle := ssSuperscript;
end;
if b then
begin
System.Delete(s, i, 5);
Inc(FPosition, 5);
continue;
end;
end
// <sub>, <sup> tags
else if (i + 5 <= Length(s)) and (s[i + 5] = '>') then
begin
if (Pos('/SUB>', AnsiUpperCase(s)) = i + 1) or (Pos('/SUP>', AnsiUpperCase(s)) = i + 1) then
begin
FSize := FDefSize;
FAddY := 0;
b := True;
Self.FSubStyle := ssNormal;
end;
if b then
begin
System.Delete(s, i, 6);
Inc(FPosition, 6);
continue;
end;
end
else if (i + 7 <= Length(s)) and ((s[i + 1] = 'n') or (s[i + 1] = 'N')) then
begin
if Pos('NOWRAP>', AnsiUpperCase(s)) = i + 1 then
begin
FDontWRAP := True;
System.Delete(s, i, 8);
Inc(FPosition, 8);
continue;
end;
end
// <strike> tag
else if (i + 1 <= Length(s)) and ((s[i + 1] = 's') or (s[i + 1] = 'S')) then
begin
if Pos('STRIKE>', AnsiUpperCase(s)) = i + 1 then
begin
FStyle := FStyle + [fsStrikeOut];
System.Delete(s, i, 8);
Inc(FPosition, 8);
continue;
end;
end
// </b>, </u>, </i>, </strike>, </font>, </sub>, </sup> tags
else if (i + 1 <= Length(s)) and (s[i + 1] = '/') then
begin
if (i + 3 <= Length(s)) and (s[i + 3] = '>') then
begin
case s[i + 2] of
'b','B': FStyle := FStyle - [fsBold];
'i','I': FStyle := FStyle - [fsItalic];
'u','U': FStyle := FStyle - [fsUnderline];
else
b := False;
end;
if b then
begin
System.Delete(s, i, 4);
Inc(FPosition, 4);
continue;
end;
end
else if (Pos('STRIKE>', AnsiUpperCase(s)) = i + 2) then
begin
FStyle := FStyle - [fsStrikeOut];
System.Delete(s, i, 9);
Inc(FPosition, 9);
continue;
end
else if (Pos('NOWRAP>', AnsiUpperCase(s)) = i + 2) then
begin
FDontWRAP := False;
System.Delete(s, i, 9);
Inc(FPosition, 9);
continue;
end
else if Pos('FONT>', AnsiUpperCase(s)) = i + 2 then
begin
FColor := FDefColor;
System.Delete(s, i, 7);
Inc(FPosition, 7);
continue;
end
else if (Pos('SUB>', AnsiUpperCase(s)) = i + 2) or
(Pos('SUP>', AnsiUpperCase(s)) = i + 2) then
begin
FSize := FDefSize;
FAddY := 0;
System.Delete(s, i, 6);
Inc(FPosition, 6);
continue;
end
end
// <font color = ...> tag
else if Pos('FONT COLOR', AnsiUpperCase(s)) = i + 1 then
begin
j := i + 11;
while (j <= Length(s)) and (s[j] <> '=') do
Inc(j);
Inc(j);
while (j <= Length(s)) and (s[j] = ' ') do
Inc(j);
j1 := j;
while (j <= Length(s)) and (s[j] <> '>') do
Inc(j);
cl := Copy(s, j1, j - j1);
if cl <> '' then
begin
if (Length(cl) > 3) and (cl[1] = '"') and (cl[2] = '#') and
(cl[Length(cl)] = '"') then
begin
cl := '$' + Copy(cl, 3, Length(cl) - 3);
FColor := StrToInt(cl);
FColor := (FColor and $000000FF) div 65536 +
(FColor and $00FF0000) * 65536 +
(FColor and $0000FF00);
System.Delete(s, i, j - i + 1);
Inc(FPosition, j - i + 1);
continue;
end
else if IdentToAlphaColor('cl' + cl, FColor) then
begin
System.Delete(s, i, j - i + 1);
Inc(FPosition, j - i + 1);
continue;
end;
end;
end
end;
AddTag;
Inc(i);
Inc(FPosition);
end;
if Length(s) = 0 then
begin
AddTag;
s := ' ';
end;
end;
{ TAdvancedTextRenderer }
function TAdvancedTextRenderer.MeasureTextWidth(const aText: String): Single;
var
r: TRectF;
begin
r := RectF(0, 0, 10000, 10000);
if FFastRender <> nil then
FFastRender.MeasureText(r, aText, False, [], TTextAlign.taLeading, TTextAlign.taLeading)
else
Canvas.MeasureText(r, aText, False, [], TTextAlign.taLeading, TTextAlign.taLeading);
Result := r.Width;
end;
procedure TAdvancedTextRenderer.SplitToParagraphs(const text: String);
var
style: TStyleDescriptor;
lines: TStringDynArray;
line: String;
i, lineLength, originalCharIndex: Integer;
paragraph: TParagraph;
begin
style := StyleDescriptor(Font.Style, Font.Color, TBaseLine.Normal);
lines := SplitString(text, #10);
originalCharIndex := 0;
for i := 0 to Length(lines) - 1 do
begin
line := lines[i];
lineLength := Length(line);
if (lineLength > 0) and (line[lineLength] = #13) then
Delete(line, lineLength, 1);
paragraph := TParagraph.Create(line, self, originalCharIndex);
FParagraphs.Add(paragraph);
style := paragraph.WrapLines(style);
Inc(originalCharIndex, lineLength + 1);
end;
// skip empty paragraphs at the end
for i := FParagraphs.Count - 1 downto 0 do
begin
if FParagraphs[i].IsEmpty then
begin
FParagraphs[i].Free;
FParagraphs.Delete(i);
end
else
break;
end;
end;
procedure TAdvancedTextRenderer.AdjustParagraphLines;
var
i: Integer;
height, offsetY: Single;
paragraph: TParagraph;
line: TLine;
begin
// calculate text height
height := 0;
for paragraph in Paragraphs do
height := height + paragraph.Lines.Count * LineHeight;
// calculate Y offset
offsetY := DisplayRect.Top;
if VertAlign = vaCenter then
offsetY := offsetY + (DisplayRect.Height - height) / 2
else if VertAlign = vaBottom then
offsetY := offsetY + (DisplayRect.Height - height) - 1;
for i := 0 to Paragraphs.Count - 1 do
begin
paragraph := Paragraphs[i];
paragraph.AlignLines((i = Paragraphs.Count - 1) and ForceJustify);
// adjust line tops
for line in paragraph.Lines do
begin
line.Top := offsetY;
line.MakeUnderlines;
offsetY := offsetY + LineHeight;
end;
end;
end;
procedure TAdvancedTextRenderer.Draw;
var
state: TCanvasSaveState;
m, OldM: TMatrix;
paragraph: TParagraph;
begin
// set clipping
// avoid bug under win platform, after state restore matrix has unexpected values
OldM := Canvas.Matrix;
State := Canvas.SaveState;
try
{ increase bounds for 2 pixels }
{ increase Top for 1 * Scale (preview or print) pixels for subscripts }
Canvas.IntersectClipRect(RectF(DisplayRect.Left, DisplayRect.Top - 1 * FScaleFactor, DisplayRect.Right + 2, DisplayRect.Bottom));
if Angle <> 0 then
begin
m := CreateRotationMatrix(-DegToRad(Angle));
// offset
m.m31 := OldM.m31 + DisplayRect.Left + DisplayRect.Width / 2;
m.m32 := OldM.m32 + DisplayRect.Top + DisplayRect.Height / 2;
Canvas.SetMatrix(m);
end;
for paragraph in Paragraphs do
paragraph.Draw;
finally
// restore clipping
Canvas.RestoreState(state);
Canvas.SetMatrix(OldM);
end;
end;
function TAdvancedTextRenderer.CalcHeight: Single;
var
charsFit: Integer;
style: TStyleDescriptor;
begin
Result := CalcHeight(charsFit, style);
end;
function TAdvancedTextRenderer.CalcHeight(var charsFit: Integer; var style: TStyleDescriptor): Single;
var
i, j: Integer;
height, displayHeight: Single;
line: TLine;
begin
charsFit := 0;
style := NullStyle;
height := 0;
displayHeight := DisplayRect.Height;
if LineHeight > displayHeight then
begin
Result := 0;
Exit;
end;
for i := 0 to Paragraphs.Count - 1 do
begin
for j := 0 to Paragraphs[i].Lines.Count - 1 do
begin
line := Paragraphs[i].Lines[j];
height := height + LineHeight;
if (charsFit = 0) and (height > displayHeight) then
begin
charsFit := line.OriginalCharIndex;
if HtmlTags then
style := line.Style;
height := height - LineHeight;
break;
end;
end;
if (charsFit <> 0) then break;
end;
if charsFit = 0 then
charsFit := Length(FText);
Result := height ;
end;
function TAdvancedTextRenderer.CalcWidth: Single;
var
paragraph: TParagraph;
line: TLine;
width: Single;
begin
width := 0;
for paragraph in Paragraphs do
for line in paragraph.Lines do
begin
if width < line.Width then
width := line.Width;
end;
Result := width + FSpaceWidth;
end;
function TAdvancedTextRenderer.GetTabPosition(pos: Single): Single;
var
tabOffset, tabSize: Single;
tabPosition: Integer;
begin
tabOffset := 0;
tabSize := 64;
tabPosition := Trunc((pos - tabOffset) / tabSize);
if pos < tabOffset then
Result := tabOffset
else
Result := (tabPosition + 1) * tabSize + tabOffset;
end;
constructor TAdvancedTextRenderer.Create(aCanvas: TCanvas; const aText: String;
aFont: TfrxFont; rect: TRectF; aHorzAlign: TfrxHAlign; aVertAlign: TfrxVAlign;
aLineHeight: Single; aAngle: Integer; aWordWrap: Boolean; aForceJustify: Boolean;
aHtmlTags: Boolean; aPdfMode: Boolean; aScaLeFactor: Single);
begin
if aCanvas is TfrxFastCanvasLayer then
begin
FFastRender := TfrxFastCanvasLayer(aCanvas);
FCanvas := FFastRender.Canvas;
end
else
FCanvas := aCanvas;
FScaleFactor := aScaLeFactor;
if SameValue(FScaleFactor, 0, 0.09) then
FScaleFactor := 0.1;
FParagraphs := TList<TParagraph>.Create;
FText := aText;
FFont := aFont;
FDisplayRect := rect;
FHorzAlign := aHorzAlign;
FVertAlign := aVertAlign;
FLineHeight := aLineHeight;
FFontLineHeight := aFont.GetHeight(FCanvas) + 2;
if FLineHeight = 0 then
FLineHeight := FFontLineHeight
else
FFontLineHeight := FLineHeight;
FAngle := aAngle;
FWordWrap := aWordWrap;
FForceJustify := aForceJustify;
FHtmlTags := aHtmlTags;
FPDFMode := aPdfMode;
aFont.AssignToCanvas(FCanvas);
{$IFDEF DELPHI25}
{$IFDEF MSWINDOWS}
// workaround for Tokyo - DoRenderLayout now has MeasureString call and calculates one space symbol incorrect
FSpaceWidth := Round(MeasureTextWidth(' ') / 5 );
{$ELSE}
FSpaceWidth := MeasureTextWidth(' ');
{$ENDIF}
{$ELSE}
FSpaceWidth := MeasureTextWidth(' ');
{$ENDIF}
if Canvas.ClassName = 'TCanvasGdiPlus' then
FSpaceWidth := FSpaceWidth - FScaleFactor;
FSymbolWidth := MeasureTextWidth('W');
if Angle <> 0 then
begin
// shift displayrect
FDisplayRect.Left := -rect.Width / 2;
FDisplayRect.Top := -rect.Height / 2;
FDisplayRect.Right := FDisplayRect.Left + rect.Width;
FDisplayRect.Bottom := FDisplayRect.Top + rect.Height;
// rotate displayrect if angle is 90 or 270
if ((Angle >= 90) and (Angle < 180)) or ((Angle >= 270) and (Angle < 360)) then
FDisplayRect := RectF(DisplayRect.Top, DisplayRect.Left, DisplayRect.Bottom, DisplayRect.Right);
end;
SplitToParagraphs(aText);
AdjustParagraphLines;
// restore original values
FDisplayRect := rect;
end;
destructor TAdvancedTextRenderer.Destroy;
var
paragraph: TParagraph;
begin
for paragraph in Paragraphs do
paragraph.Free;
Paragraphs.Free;
inherited;
end;
{ TParagraph }
function TParagraph.IsLast: Boolean;
begin
Result := FRenderer.Paragraphs[FRenderer.Paragraphs.Count - 1] = self;
end;
function TParagraph.IsEmpty: Boolean;
begin
Result := FText = '';
end;
function TParagraph.WrapLines(style: TStyleDescriptor): TStyleDescriptor;
var
line: TLine;
aWord: TWord;
text, currentWord, tag, colorName: String;
width, WLineWidth: Single;
skipSpace, match, isLastWord: Boolean;
i, originalCharIndex, istart, iend: Integer;
newStyle: TStyleDescriptor;
begin
line := TLine.Create(self, FOriginalCharIndex);
FLines.Add(line);
aWord := TWord.Create(line);
line.Words.Add(aWord);
WLineWidth := 0;
text := FText;
currentWord := '';
width := 0;
skipSpace := True;
originalCharIndex := FOriginalCharIndex;
i := 1;
while i <= Length(text) do
begin
if Renderer.HtmlTags and (text[i] = '<') then
begin
// probably html tag
newStyle := style;
tag := '';
match := False;
// <b>, <i>, <u>
if i + 3-1 <= Length(text) then
begin
match := True;
tag := LowerCase(Copy(text, i, 3));
if tag = '<b>' then
newStyle.FontStyle := newStyle.FontStyle + [fsBold]
else if tag = '<i>' then
newStyle.FontStyle := newStyle.FontStyle + [fsItalic]
else if tag = '<u>' then
newStyle.FontStyle := newStyle.FontStyle + [fsUnderline]
else
match := False;
if match then
Inc(i, 3);
end;
// </b>, </i>, </u>
if not match and (i + 4-1 <= Length(text)) and (text[i + 1] = '/') then
begin
match := True;
tag := LowerCase(Copy(text, i, 4));
if tag = '</b>' then
newStyle.FontStyle := newStyle.FontStyle - [fsBold]
else if tag = '</i>' then
newStyle.FontStyle := newStyle.FontStyle - [fsItalic]
else if tag = '</u>' then
newStyle.FontStyle := newStyle.FontStyle - [fsUnderline]
else
match := False;
if match then
Inc(i, 4);
end;
// <sub>, <sup>
if not match and (i + 5-1 <= Length(text)) then
begin
match := True;
tag := LowerCase(Copy(text, i, 5));
if tag = '<sub>' then
newStyle.BaseLine := TBaseLine.Subscript
else if tag = '<sup>' then
newStyle.BaseLine := TBaseLine.Superscript
else
match := False;
if match then
Inc(i, 5);
end;
// </sub>, </sup>
if not match and (i + 6-1 <= Length(text)) and (text[i + 1] = '/') then
begin
match := True;
tag := LowerCase(Copy(text, i, 6));
if (tag = '</sub>') or (tag = '</sup>') then
newStyle.BaseLine := TBaseLine.Normal
else
match := False;
if match then
Inc(i, 6);
end;
// <strike>
if not match and (i + 8-1 <= Length(text)) then
begin
tag := LowerCase(Copy(text, i, 8));
if tag = '<strike>' then
begin
newStyle.FontStyle := newStyle.FontStyle + [fsStrikeout];
match := True;
Inc(i, 8);
end;
end;
// </strike>
if not match and (i + 9-1 <= Length(text)) then
begin
tag := LowerCase(Copy(text, i, 9));
if tag = '</strike>' then
begin
newStyle.FontStyle := newStyle.FontStyle - [fsStrikeout];
match := True;
Inc(i, 9);
end;
end;
// <font color
if not match and (i + 11-1 < Length(text)) then
begin
tag := LowerCase(Copy(text, i, 11));
if tag = '<font color' then
begin
istart := i + 11;
while (istart <= Length(text)) and (text[istart] <> '=') do
Inc(istart);
Inc(istart);
while (istart <= Length(text)) and (text[istart] = ' ') do
Inc(istart);
iend := istart;
while (iend <= Length(text)) and (text[iend] <> '>') do
Inc(iend);
if iend <= Length(text) then
begin
colorName := Copy(text, istart, iend - istart);
if (colorName[1] = '"') and (colorName[Length(colorName)] = '"') then
colorName := Copy(colorName, 2, Length(colorName) - 2);
newStyle.Color := StringToAlphaColor(colorName);
i := iend + 1;
match := True;
end;
end;
end;
// </font>
if not match and (i + 7-1 <= Length(text)) then
begin
tag := LowerCase(Copy(text, i, 7));
if tag = '</font>' then
begin
newStyle.Color := Renderer.Font.Color;
match := True;
Inc(i, 7);
end;
end;
if match then
begin
// finish the word
if currentWord <> '' then
aWord.Runs.Add(TRun.Create(currentWord, style, aWord));
currentWord := '';
style := newStyle;
if i >= Length(text) then
begin
// check width
width := width + aWord.Width + Renderer.SpaceWidth;
if width > Trunc(Renderer.DisplayRect.Width - 0.5) then
begin
// line is too long, make a new line
if line.Words.Count > 1 then
begin
// if line has several words, delete the last word from the current line
line.Words.Delete(line.Words.Count - 1);
// make new line
line := TLine.Create(self, originalCharIndex);
// and add word to it
line.Words.Add(aWord);
aWord.SetLine(line);
FLines.Add(line);
end;
end;
end;
continue;
end;
end;
if (text[i] = ' ') or (text[i] = #9) or (i = Length(text)) or (WLineWidth > 0) then
begin
// finish the last word
isLastWord := i = Length(text);
if isLastWord then
begin
currentWord := currentWord + text[i];
skipSpace := False;
end;
if text[i] = #9 then
skipSpace := False;
// space
if skipSpace then
currentWord := currentWord + text[i]
else
begin
// finish the word
if currentWord <> '' then
aWord.Runs.Add(TRun.Create(currentWord, style, aWord));
// check width
width := width + aWord.Width + Renderer.SpaceWidth;
// we need addition space witdth to avoid exeeds of bounds with different scale
if (width > Trunc(Renderer.DisplayRect.Width - 0.5)) or (WLineWidth > 0) then
begin
WLineWidth := 0;
// line is too long, make a new line
width := 0;
if line.Words.Count > 1 then
begin
// if line has several words, delete the last word from the current line
line.Words.Delete(line.Words.Count - 1);
// make new line
line := TLine.Create(self, originalCharIndex);
// and add word to it
line.Words.Add(aWord);
aWord.SetLine(line);
width := width + aWord.Width + Renderer.SpaceWidth;
end
else
line := TLine.Create(self, FOriginalCharIndex + i + 1);
FLines.Add(line);
end;
// TAB symbol
if text[i] = #9 then
begin
if currentWord = '' then
line.Words.Delete(line.Words.Count - 1);
aWord := TTab.Create(line);
line.Words.Add(aWord);
// adjust width
width := Renderer.GetTabPosition(width);
end;
if not isLastWord then
begin
aWord := TWord.Create(line);
line.Words.Add(aWord);
currentWord := '';
originalCharIndex := FOriginalCharIndex + i + 1;
skipSpace := True;
WLineWidth := 0;
end;
end;
end
else
begin
// symbol
currentWord := currentWord + text[i];
skipSpace := False;
// word wrap - do something better than call measure text every time
// TODO
// use aproximate width first
if FRenderer.WordWrap and (Length(currentWord) * renderer.SymbolWidth >=
Trunc(renderer.DisplayRect.Width - 0.5)) then
begin
while (Renderer.MeasureTextWidth(currentWord) >
Trunc(renderer.DisplayRect.Width - 0.5)) and (Length(currentWord) > 1) do
begin
Dec(i);
Delete(currentWord, Length(currentWord), 1);
WLineWidth := 1; // used as flag
end;
if (WLineWidth = 1) or (Length(currentWord) = 1) then
begin
Dec(i, 1);
WLineWidth := Renderer.MeasureTextWidth(currentWord);
end;
end;
end;
Inc(i);
end;
Result := style;
end;
procedure TParagraph.AlignLines(forceJustify: Boolean);
var
i: Integer;
align: TfrxHAlign;
begin
for i := 0 to Lines.Count - 1 do
begin
align := Renderer.HorzAlign;
if (align = TfrxHAlign.haBlock) and (i = Lines.Count - 1) and not forceJustify then
align := TfrxHAlign.haLeft;
Lines[i].AlignWords(align);
end;
end;
procedure TParagraph.Draw;
var
line: TLine;
begin
for line in Lines do
line.Draw;
end;
constructor TParagraph.Create(const text: String; renderer: TAdvancedTextRenderer; originalCharIndex: Integer);
begin
FLines := TList<TLine>.Create;
FText := text;
FRenderer := renderer;
FOriginalCharIndex := originalCharIndex;
end;
destructor TParagraph.Destroy;
var
line: TLine;
begin
for line in Lines do
line.Free;
Lines.Free;
inherited;
end;
{ TLine }
function TLine.GetLeft: Single;
begin
if Words.Count > 0 then
Result := Words[0].Left
else
Result := 0;
end;
function TLine.GetRenderer: TAdvancedTextRenderer;
begin
Result := FParagraph.Renderer;
end;
function TLine.GetStyle: TStyleDescriptor;
begin
Result := NullStyle;
if Words.Count > 0 then
if Words[0].Runs.Count > 0 then
Result := Words[0].Runs[0].Style;
end;
function TLine.GetText: String;
var
word: TWord;
begin
Result := '';
for word in Words do
begin
if Result <> '' then
Result := Result + ' ';
Result := Result + word.Text;
end;
end;
function TLine.IsLast: Boolean;
begin
Result := FParagraph.Lines[FParagraph.Lines.Count - 1] = self;
end;
procedure TLine.PrepareUnderlines(list: TList<TRectF>; style: TFontStyle);
var
left, right: Single;
styleOn: Boolean;
aWord: TWord;
run: TRun;
fnt: TfrxFont;
begin
list.Clear;
if Words.Count = 0 then
Exit;
left := 0;
right := 0;
styleOn := False;
for aWord in Words do
begin
for run in aWord.Runs do
begin
fnt := run.GetFont;
if style in fnt.Style then
begin
if not styleOn then
begin
styleOn := True;
left := run.Left;
end;
right := run.Left + run.Width;
end;
if not (style in fnt.Style) and styleOn then
begin
styleOn := False;
list.Add(RectF(left, Top, right, Top));
end;
fnt.Free;
end;
end;
// close the style
if styleOn then
list.Add(RectF(left, Top, right, Top));
end;
procedure TLine.AlignWords(align: TfrxHAlign);
var
left, rectWidth, delta, curDelta: Single;
i: Integer;
aWord: TWord;
begin
FWidth := 0;
left := 0;
i := 0;
while i < Words.Count do
begin
aWord := Words[i];
aWord.Left := left;
if aWord is TTab then
begin
left := Renderer.GetTabPosition(left);
// remove tab
Words.Delete(i);
aWord.Free;
Dec(i);
end
else
left := left + aWord.Width + Renderer.SpaceWidth;
Inc(i);
end;
FWidth := left;
rectWidth := Renderer.DisplayRect.Width;
if align = TfrxHAlign.haBlock then
begin
if Words.Count > 1 then
begin
delta := (rectWidth - FWidth) / (Words.Count - 1);
curDelta := delta;
for i := 1 to Words.Count - 1 do
begin
FWords[i].Left := FWords[i].Left + curDelta;
curDelta := curDelta + delta;
end;
end;
end
else
begin
delta := 0;
if align = TfrxHAlign.haCenter then
delta := (rectWidth - FWidth) / 2
else if align = TfrxHAlign.haRight then
delta := rectWidth - (FWidth - Renderer.SpaceWidth);
for aWord in Words do
aWord.Left := aWord.Left + delta;
end;
// adjust X offset
for aWord in Words do
begin
if Renderer.RightToLeft then
aWord.Left := Renderer.DisplayRect.Right - aWord.Left
else
aWord.Left := aWord.Left + Renderer.DisplayRect.Left;
aWord.AdjustRuns;
if Renderer.RightToLeft and Renderer.PDFMode then
aWord.Left := aWord.Left - aWord.Width;
end;
end;
procedure TLine.MakeUnderlines;
begin
PrepareUnderlines(FUnderlines, TFontStyle.fsUnderline);
PrepareUnderlines(FStrikeouts, TFontStyle.fsStrikeout);
end;
procedure TLine.Draw;
var
aWord: TWord;
h, w, th: Single;
rect: TRectF;
begin
for aWord in Words do
aWord.Draw;
if (Underlines.Count > 0) or (Strikeouts.Count > 0) then
begin
h := Renderer.FontLineHeight;
w := h * 0.1; // to match char X offset
// invert offset in case of rtl
if Renderer.RightToLeft then
w := -w;
th := Round(Renderer.Font.Size * 0.1);
{$IFDEF Delphi25}
Renderer.Canvas.Stroke.Thickness := th;
{$ELSE}
Renderer.Canvas.StrokeThickness := th;
{$ENDIF}
Renderer.Canvas.Stroke.Color := Renderer.Font.Color;
// emulate underline & strikeout
for rect in Underlines do
Renderer.Canvas.DrawLine(
PointF(rect.Left + w, AdjY(rect.Top + h - w, th)), PointF(rect.Right + w, AdjY(rect.Top + h - w, th)), 1);
h := h / 2;
for rect in Strikeouts do
Renderer.Canvas.DrawLine(
PointF(rect.Left + w, AdjY(rect.Top + h, th)), PointF(rect.Right + w, AdjY(rect.Top + h, th)), 1);
end;
end;
constructor TLine.Create(paragraph: TParagraph; originalCharIndex: Integer);
begin
FWords := TList<TWord>.Create;
FParagraph := paragraph;
FOriginalCharIndex := originalCharIndex;
FUnderlines := TList<TRectF>.Create;
FStrikeouts := TList<TRectF>.Create;
end;
destructor TLine.Destroy;
var
aWord: TWord;
begin
for aWord in Words do
aWord.Free;
Words.Free;
Underlines.Free;
Strikeouts.Free;
inherited;
end;
{ TWord }
function TWord.GetText: String;
var
run: TRun;
begin
Result := '';
for run in Runs do
begin
Result := Result + run.Text;
end;
end;
function TWord.GetTop: Single;
begin
Result := FLine.Top;
end;
function TWord.GetRenderer: TAdvancedTextRenderer;
begin
Result := FLine.Renderer;
end;
function TWord.GetWidth: Single;
var
run: TRun;
begin
if FWidth = -1 then
begin
FWidth := 0;
for run in Runs do
FWidth := FWidth + run.Width;
end;
Result := FWidth;
end;
procedure TWord.AdjustRuns;
var
aLeft: Single;
run: TRun;
begin
aLeft := Left;
for run in Runs do
begin
run.Left := aLeft;
if Renderer.RightToLeft then
begin
aLeft := aLeft - run.Width;
if Renderer.PDFMode then
run.Left := run.Left - run.Width;
end
else
aLeft := aLeft + run.Width;
end;
end;
procedure TWord.SetLine(aLine: TLine);
begin
FLine := aLine;
end;
procedure TWord.Draw;
var
run: TRun;
begin
for run in Runs do
run.Draw;
end;
constructor TWord.Create(aLine: TLine);
begin
FRuns := TList<TRun>.Create;
FLine := aLine;
FWidth := -1;
end;
destructor TWord.Destroy;
var
run: TRun;
begin
for run in Runs do
run.Free;
FRuns.Free;
inherited;
end;
{ TRun }
function TRun.GetRenderer: TAdvancedTextRenderer;
begin
Result := FWord.Renderer;
end;
function TRun.GetTop: Single;
var
baseLine: Single;
begin
baseLine := 0;
if Style.BaseLine = TBaseLine.Subscript then
baseLine := baseLine + Renderer.FontLineHeight * 0.45
else if Style.BaseLine = TBaseLine.Superscript then
baseLine := baseLine - Renderer.FontLineHeight * 0.15;
Result := FWord.Top + baseLine;
end;
function TRun.GetFont(disableUnderlinesStrikeouts: Boolean): TfrxFont;
var
fontSize: Single;
fontStyle: TFontStyles;
begin
fontSize := Renderer.Font.Size;
if Style.BaseLine <> TBaseLine.Normal then
fontSize := fontSize * 0.6;
fontStyle := Style.FontStyle;
if disableUnderlinesStrikeouts then
fontStyle := fontStyle - [fsUnderline, fsStrikeout];
Result := TfrxFont.Create;
Result.Name := Renderer.Font.Name;
Result.Color := Style.Color;
Result.Size := fontSize;
Result.Style := fontStyle;
end;
function TRun.GetFont: TfrxFont;
begin
Result := GetFont(false);
end;
procedure TRun.Draw;
var
font: TfrxFont;
begin
font := GetFont(True);
font.AssignToCanvas(Renderer.Canvas);
if Renderer.FFastRender <> nil then
Renderer.FFastRender.FillText(RectF(Left, Top, Left + 10000, Top + 10000), FText, False, 1, [], TTextAlign.taLeading, TTextAlign.taLeading)
else
Renderer.Canvas.FillText(RectF(Left, Top, Left + 10000, Top + 10000), FText, False, 1, [], TTextAlign.taLeading, TTextAlign.taLeading);
font.Free;
end;
constructor TRun.Create(const aText: String; aStyle: TStyleDescriptor; aWord: TWord);
var
font: TfrxFont;
begin
FText := aText;
FStyle := aStyle;
FWord := aWord;
font := GetFont;
font.AssignToCanvas(Renderer.Canvas);
FWidth := Renderer.MeasureTextWidth(aText);
font.Free;
end;
end.