Archivado/Componentes.Terceros.FastReport
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
master
Componentes.Terceros.FastRe.../internal/4.2/1/Source/frxGraphicUtils.pas
david f2dddaa81b Importación inicial 
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.FastReport@13 475b051d-3a53-6940-addd-820bf0cfe0d7
2007-11-18 19:40:07 +00:00

1663 lines
43 KiB
ObjectPascal
Raw Permalink Blame History

{******************************************}
{ }
{ FastReport v4.0 }
{ Graphic routines }
{ }
{ Copyright (c) 1998-2007 }
{ by Alexander Tzyganenko, }
{ Fast Reports Inc. }
{ }
{******************************************}
unit frxGraphicUtils;
interface
{$I frx.inc}
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs,
frxClass, frxUnicodeUtils
{$IFDEF Delphi6}
, Variants
{$ENDIF};
type
TIntArray = array[0..MaxInt div 4 - 1] of Integer;
PIntArray = ^TIntArray;
TfrxHTMLTag = class(TObject)
public
Position: Integer;
Size: Integer;
AddY: Integer;
Style: TFontStyles;
Color: Integer;
Default: Boolean;
Small: Boolean;
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: LongInt;
FDefColor: LongInt;
FDefSize: Integer;
FDefStyle: TFontStyles;
FItems: TList;
FPosition: Integer;
FSize: Integer;
FStyle: TFontStyles;
FTempArray: PIntArray;
procedure NewLine;
procedure Wrap(TagsCount: Integer; AddBreak: Boolean);
function Add: TfrxHTMLTag;
function FillCharSpacingArray(var ar: PIntArray; const s: WideString;
Canvas: TCanvas; LineIndex, Add: Integer; Convert: Boolean): Integer;
function GetItems(Index: Integer): TfrxHTMLTags;
function GetPrevTag: TfrxHTMLTag;
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;
TfrxDrawText = class(TObject)
private
// internals
FBMP: TBitmap;
FLocked: Boolean;
FCanvas: TCanvas;
FDefPPI: Integer;
FScrPPI: Integer;
FTempArray: PIntArray;
// data passed by SetXXX calls
FFontSize: Integer;
FHTMLTags: TfrxHTMLTagsList;
FCharSpacing: Extended;
FLineSpacing: Extended;
FOptions: Integer;
FOriginalRect: TRect;
FParagraphGap: Extended;
FPlainText: WideString;
FPrintScale: Extended;
FRotation: Integer;
FRTLReading: Boolean;
FScaledRect: TRect;
FScaleX: Extended;
FScaleY: Extended;
FText: TWideStrings;
FWordBreak: Boolean;
FWordWrap: Boolean;
FWysiwyg: Boolean;
function GetWrappedText: WideString;
function IsPrinter(C: TCanvas): Boolean;
procedure DrawTextLine(C: TCanvas; const s: WideString;
X, Y, DX, LineIndex: Integer; Align: TfrxHAlign; var fh, oldfh: HFont);
procedure WrapTextLine(s: WideString; Width, FirstLineWidth,
CharSpacing: Integer);
public
constructor Create;
destructor Destroy; override;
// Call these methods in the same order
procedure SetFont(Font: TFont);
procedure SetOptions(WordWrap, HTMLTags, RTLReading, WordBreak,
Clipped, Wysiwyg: Boolean; Rotation: Integer);
procedure SetGaps(ParagraphGap, CharSpacing, LineSpacing: Extended);
procedure SetDimensions(ScaleX, ScaleY, PrintScale: Extended;
OriginalRect, ScaledRect: TRect);
procedure SetText(Text: TWideStrings);
procedure SetParaBreaks(FirstParaBreak, LastParaBreak: Boolean);
function DeleteTags(const Txt: WideString): WideString;
// call these methods only after methods listed above
procedure DrawText(C: TCanvas; HAlign: TfrxHAlign; VAlign: TfrxVAlign);
function CalcHeight: Extended;
function CalcWidth: Extended;
function LineHeight: Extended;
function TextHeight: Extended;
// returns the text that don't fit in the bounds
function GetInBoundsText: WideString;
function GetOutBoundsText(var ParaBreak: Boolean): WideString;
function UnusedSpace: Extended;
// call these methods before and after doing something
procedure Lock;
procedure Unlock;
property Canvas: TCanvas read FCanvas;
property DefPPI: Integer read FDefPPI;
property ScrPPI: Integer read FScrPPI;
property WrappedText: WideString read GetWrappedText;
end;
var
frxDrawText: TfrxDrawText;
implementation
uses frxPrinter;
const
glasn: String = '<27>Ũ<EFBFBD><C5A8><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>';
soglasn: String = '<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>';
znaks: String = '<27><>';
znaks1: String = '<27>';
{ <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>
<20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>.
1. <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><>
<20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>, <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>; <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>-<2D><>, <20><>-<2D><><EFBFBD>.
2. <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>.
<20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<20><><EFBFBD>-<2D><><EFBFBD> <20><>-<2D><><EFBFBD><EFBFBD>
3. <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20> <20> <20> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>.
<20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<20><><EFBFBD>-<2D><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD>-<2D><><EFBFBD>
4. <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>.
<20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<20><>-<2D><><EFBFBD> <20><><EFBFBD>-<2D><>
5. <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD>.
<20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<20>-<2D><><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD><EFBFBD>-<2D> <20><><EFBFBD>-<2D><><EFBFBD>
6. <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD>
<20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>.
<20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<20><>-<2D><><EFBFBD><EFBFBD> <20><><EFBFBD>-<2D><><EFBFBD> }
{ <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> }
function BreakRussianWord(const s: WideString): String;
var
i, j: Integer;
CanBreak: Boolean;
function Check1and5(const s: WideString): Boolean;
var
i: Integer;
begin
Result := False;
if Length(s) >= 2 then
for i := 1 to Length(s) do
if Pos(s[i], glasn) <> 0 then
begin
Result := True;
break;
end;
end;
begin
Result := '';
if Length(s) < 4 then Exit;
for i := 1 to Length(s) do
begin
CanBreak := False;
if Pos(s[i], soglasn) <> 0 then
begin
CanBreak := True;
{ 2 }
if (i < Length(s)) and (Pos(s[i + 1], glasn) <> 0) then
CanBreak := False;
{ 3 }
if (i < Length(s)) and (Pos(s[i + 1], znaks) <> 0) then
CanBreak := False;
end;
if Pos(s[i], glasn) <> 0 then
begin
CanBreak := True;
{ 4 }
if (i < Length(s)) and (Pos(s[i + 1], znaks1) <> 0) then
CanBreak := False;
{ 6 }
if (i < Length(s) - 2) and (Pos(s[i + 1], soglasn) <> 0) and
(s[i + 1] = s[i + 2]) and (Pos(s[i + 3], glasn) <> 0) then
CanBreak := False;
end;
if CanBreak then
Result := Result + Chr(i);
end;
{ 1, 5 }
for i := 1 to Length(Result) do
begin
j := Ord(Result[i]);
if not (Check1and5(Copy(s, 1, j)) and Check1and5(Copy(s, j + 1, 255))) then
Result[i] := #255;
end;
while Pos(#255, Result) <> 0 do
Delete(Result, Pos(#255, Result), 1);
end;
procedure IncArray(Ar: PIntArray; x1, x2, n, one: Integer);
var
xm: Integer;
begin
if n <= 0 then Exit;
xm := (x2 - x1 + 1) div 2;
if xm = 0 then
xm := 1;
if n = 1 then
Inc(Ar[x1 + xm - 1], one)
else
begin
IncArray(Ar, x1, x1 + xm - 1, n div 2, one);
IncArray(Ar, x1 + xm, x2, n - n div 2, one);
end;
end;
function CreateRotatedFont(Font: TFont; Rotation: Integer): HFont;
var
F: TLogFont;
begin
GetObject(Font.Handle, SizeOf(TLogFont), @F);
F.lfEscapement := Rotation * 10;
F.lfOrientation := Rotation * 10;
Result := CreateFontIndirect(F);
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;
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;
GetMem(FTempArray, SizeOf(Integer) * 32768);
end;
destructor TfrxHTMLTagsList.Destroy;
begin
Clear;
FItems.Free;
FreeMem(FTempArray, SizeOf(Integer) * 32768);
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;
FPosition := 1;
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;
// 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
(FColor = PrevTag.Color) and
(FSize = PrevTag.Size)
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;
end
else if Pos('SUP>', AnsiUpperCase(s)) = i + 1 then
begin
FSize := Round(FDefSize / 1.5);
FAddY := 0;
b := True;
end;
if b then
begin
System.Delete(s, i, 5);
Inc(FPosition, 5);
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('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 $00FF0000) div 65536 +
(FColor and $000000FF) * 65536 +
(FColor and $0000FF00);
System.Delete(s, i, j - i + 1);
Inc(FPosition, j - i + 1);
continue;
end
else if IdentToColor('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;
function TfrxHTMLTagsList.FillCharSpacingArray(var ar: PIntArray; const s: WideString;
Canvas: TCanvas; LineIndex, Add: Integer; Convert: Boolean): Integer;
var
i, n: Integer;
Tags: TfrxHTMLTags;
Tag: TfrxHTMLTag;
procedure BreakArray;
var
i, j, offs: Integer;
Size: TSize;
ansis: String;
begin
if (Win32Platform <> VER_PLATFORM_WIN32_NT) or (Canvas.Font.Charset <> DEFAULT_CHARSET) then
begin
ansis := s;
GetTextExtentExPoint(Canvas.Handle, PChar(ansis), n, 0, nil,
@FTempArray[0], Size);
end
else
GetTextExtentExPointW(Canvas.Handle, PWideChar(s), n, 0, nil,
@FTempArray[0], Size);
i := 0;
repeat
if FTempArray[i] = 32767 then
begin
offs := FTempArray[i - 1];
if (Win32Platform <> VER_PLATFORM_WIN32_NT) or (Canvas.Font.Charset <> DEFAULT_CHARSET) then
begin
ansis := s;
GetTextExtentExPoint(Canvas.Handle, PChar(ansis) + i, n - i, 0, nil,
@FTempArray[i], Size);
end
else
GetTextExtentExPointW(Canvas.Handle, PWideChar(s) + i, n - i, 0, nil,
@FTempArray[i], Size);
for j := i to n - 1 do
if FTempArray[j] = 32767 then
begin
i := j - 1;
break;
end
else
FTempArray[j] := FTempArray[j] + offs;
end;
Inc(i);
until i >= n;
end;
begin
Result := 0;
n := Length(s);
Tags := Items[LineIndex];
Tag := Tags.Items[0];
if not Tag.Default then
Canvas.Font.Style := Tag.Style;
BreakArray;
for i := 0 to n - 1 do
begin
Tag := Tags.Items[i];
if (i <> 0) and not Tag.Default then
begin
Canvas.Font.Style := Tag.Style;
BreakArray;
end;
if i > 0 then
Ar[i] := FTempArray[i] - FTempArray[i - 1] + Add else
Ar[i] := FTempArray[i] + Add;
if Tag.Small then
Ar[i] := Round(Ar[i] / 1.5);
Inc(Result, Ar[i]);
if Convert and (i > 0) then
Inc(Ar[i], Ar[i - 1]);
end;
end;
{ TfrxDrawText }
constructor TfrxDrawText.Create;
begin
FBMP := TBitmap.Create;
FCanvas := FBMP.Canvas;
FDefPPI := 600;
FScrPpi := 96;
FHTMLTags := TfrxHTMLTagsList.Create;
FText := TWideStrings.Create;
FWysiwyg := True;
GetMem(FTempArray, SizeOf(Integer) * 32768);
end;
destructor TfrxDrawText.Destroy;
begin
FBMP.Free;
FHTMLTags.Free;
FText.Free;
FreeMem(FTempArray, SizeOf(Integer) * 32768);
inherited;
end;
procedure TfrxDrawText.SetFont(Font: TFont);
var
h: Integer;
begin
FFontSize := Font.Size;
h := -Round(FFontSize * FDefPPI / 72); // height is as in the 600 dpi printer
FCanvas.Lock;
try
with FCanvas.Font do
begin
if Name <> Font.Name then
Name := Font.Name;
if Height <> h then
Height := h;
if Style <> Font.Style then
Style := Font.Style;
if Charset <> Font.Charset then
Charset := Font.Charset;
if Color <> Font.Color then
Color := Font.Color;
end;
finally
FCanvas.Unlock;
end;
end;
procedure TfrxDrawText.SetOptions(WordWrap, HTMLTags, RTLReading,
WordBreak, Clipped, Wysiwyg: Boolean; Rotation: Integer);
begin
FWordWrap := WordWrap;
FHTMLTags.AllowTags := HTMLTags;
FRTLReading := RTLReading;
FOptions := 0;
if RTLReading then
FOptions := ETO_RTLREADING;
if Clipped then
FOptions := FOptions or ETO_CLIPPED;
FWordBreak := WordBreak;
FRotation := Rotation mod 360;
FWysiwyg := Wysiwyg;
end;
procedure TfrxDrawText.SetDimensions(ScaleX, ScaleY, PrintScale: Extended;
OriginalRect, ScaledRect: TRect);
begin
FScaleX := ScaleX;
FScaleY := ScaleY;
FPrintScale := PrintScale;
FOriginalRect := OriginalRect;
FScaledRect := ScaledRect;
end;
procedure TfrxDrawText.SetGaps(ParagraphGap, CharSpacing, LineSpacing: Extended);
begin
FParagraphGap := ParagraphGap;
FCharSpacing := CharSpacing;
FLineSpacing := LineSpacing;
end;
procedure TfrxDrawText.SetText(Text: TWideStrings);
var
i, j, n, Width: Integer;
s: WideString;
Style: TFontStyles;
FPPI: Extended;
begin
FCanvas.Lock;
try
FPlainText := '';
FText.Clear;
finally
FCanvas.Unlock;
end;
n := Text.Count;
if n = 0 then Exit;
FCanvas.Lock;
try
// set up html engine
FHTMLTags.SetDefaults(FCanvas.Font.Color, FFontSize, FCanvas.Font.Style);
Style := FCanvas.Font.Style;
// width of the wrap area
Width := FOriginalRect.Right - FOriginalRect.Left;
if ((FRotation >= 90) and (FRotation < 180)) or
((FRotation >= 270) and (FRotation < 360)) then
Width := FOriginalRect.Bottom - FOriginalRect.Top;
for i := 0 to n - 1 do
begin
j := FText.Count;
s := Text[i];
if s = '' then
s := ' ';
FPlainText := FPlainText + s + #13#10;
FPPI := FDefPPI / FScrPPI;
WrapTextLine(s,
Round(Width * FPPI),
Round((Width - FParagraphGap) * FPPI),
Round(FCharSpacing * FPPI));
if FText.Count <> j then
begin
FText.Objects[j] := Pointer(1); // mark the begin of paragraph:
if FText.Count - 1 = j then // it will be needed in DrawText
FText.Objects[j] := Pointer(3) else // both begin and end at one line
FText.Objects[FText.Count - 1] := Pointer(2); // mark the end of paragraph
end;
end;
FCanvas.Font.Style := Style;
finally
FCanvas.Unlock;
end;
end;
procedure TfrxDrawText.SetParaBreaks(FirstParaBreak, LastParaBreak: Boolean);
begin
if FText.Count = 0 then Exit;
if FirstParaBreak then
FText.Objects[0] := Pointer(Integer(FText.Objects[0]) and not 1);
if LastParaBreak then
FText.Objects[FText.Count - 1] := Pointer(Integer(FText.Objects[FText.Count - 1]) and not 2);
end;
function TfrxDrawText.DeleteTags(const Txt: WideString): WideString;
begin
Result := Txt;
FHTMLTags.ExpandHTMLTags(Result);
end;
procedure TfrxDrawText.WrapTextLine(s: WideString;
Width, FirstLineWidth, CharSpacing: Integer);
var
n, i, Offset, LineBegin, LastSpace, BreakPos: Integer;
sz: TSize;
TheWord: WideString;
WasBreak: Boolean;
function BreakWord(const s: WideString; LineBegin, CurPos, LineEnd: Integer): WideString;
var
i, BreakPos: Integer;
TheWord, Breaks: WideString;
begin
// get the whole word
i := CurPos;
while (i <= LineEnd) and (Pos(s[i], ' .,-;') = 0) do
Inc(i);
TheWord := Copy(s, LineBegin, i - LineBegin);
// get available break positions
Breaks := BreakRussianWord(AnsiUpperCase(TheWord));
// find the closest position
BreakPos := CurPos - LineBegin;
for i := Length(Breaks) downto 1 do
if Ord(Breaks[i]) < BreakPos then
begin
BreakPos := Ord(Breaks[i]);
break;
end;
if BreakPos <> CurPos - LineBegin then
Result := Copy(TheWord, 1, BreakPos) else
Result := '';
end;
begin
// remove all HTML tags and build the tag list
FHTMLTags.NewLine;
FHTMLTags.ExpandHTMLTags(s);
FHTMLTags.FPosition := FHTMLTags.FPosition + 2;
n := Length(s);
if (n < 2) or not FWordWrap then // no need to wrap a string with 0 or 1 symbol
begin
FText.Add(s);
Exit;
end;
// get the intercharacter spacing table and calculate the width
FCanvas.Lock;
try
sz.cx := FHTMLTags.FillCharSpacingArray(FTempArray, s, FCanvas,
FHTMLTags.Count - 1, CharSpacing, True);
finally
FCanvas.Unlock;
end;
// text fits, no need to wrap it
if sz.cx < FirstLineWidth then
begin
FText.Add(s);
Exit;
end;
Offset := 0;
i := 1;
LineBegin := 1; // index of the first symbol in the current line
LastSpace := 1; // index of the last space symbol in the current line
while i <= n do
begin
if s[i] = ' ' then
LastSpace := i;
if FTempArray[i - 1] - Offset > FirstLineWidth then // need wrap
begin
if LastSpace = LineBegin then // there is only one word without spaces...
begin
if i <> LineBegin then // ... and it has more than 1 symbol
begin
if FWordBreak then
begin
TheWord := BreakWord(s, LineBegin, i, n);
WasBreak := TheWord <> '';
if not WasBreak then
TheWord := Copy(s, LineBegin, i - LineBegin);
if WasBreak then
FText.Add(TheWord + '-') else
FText.Add(TheWord);
BreakPos := Length(TheWord);
FHTMLTags.Wrap(BreakPos, WasBreak);
LastSpace := LineBegin + BreakPos - 1;
end
else
begin
FText.Add(Copy(s, LineBegin, i - LineBegin));
FHTMLTags.Wrap(i - LineBegin, False);
LastSpace := i - 1;
end;
end
else
begin
FText.Add(s[LineBegin]); // can't wrap 1 symbol, just add it to the new line
FHTMLTags.Wrap(1, False);
end;
end
else // we have a space symbol inside
begin
if FWordBreak then
begin
TheWord := BreakWord(s, LastSpace + 1, i, n);
WasBreak := TheWord <> '';
if WasBreak then
FText.Add(Copy(s, LineBegin, LastSpace - LineBegin + 1) + TheWord + '-') else
FText.Add(Copy(s, LineBegin, LastSpace - LineBegin));
BreakPos := LastSpace - LineBegin + Length(TheWord) + 1;
FHTMLTags.Wrap(BreakPos, WasBreak);
if WasBreak then
LastSpace := LineBegin + BreakPos - 1;
end
else
begin
FText.Add(Copy(s, LineBegin, LastSpace - LineBegin));
FHTMLTags.Wrap(LastSpace - LineBegin + 1, False);
end;
end;
Offset := FTempArray[LastSpace - 1]; // starting a new line
i := LastSpace;
Inc(LastSpace);
LineBegin := LastSpace;
FirstLineWidth := Width; // this line is not first, so use Width
end;
Inc(i);
end;
if n - LineBegin + 1 > 0 then // put the rest of line to FText
FText.Add(Copy(s, LineBegin, n - LineBegin + 1));
end;
procedure TfrxDrawText.DrawTextLine(C: TCanvas; const s: WideString;
X, Y, DX, LineIndex: Integer; Align: TfrxHAlign; var fh, oldfh: HFont);
var
spaceAr: PIntArray;
n, i, j, cw, neededSize, extraSize, spaceCount: Integer;
add1, add2, add3, addCount: Integer;
ratio: Extended;
Sz, prnSz, PPI: Integer;
Tag: TfrxHTMLTag;
CosA, SinA: Extended;
Style: TFontStyles;
FPPI: Extended;
function CountSpaces: Integer;
var
i: Integer;
begin
Result := 0;
for i := 0 to n - 1 do
begin
spaceAr[i] := 0;
if (s[i + 1] = ' ') or (s[i + 1] = #$A0) then
begin
Inc(Result);
spaceAr[i] := 1;
end;
end;
end;
function CalcWidth(Index, Count: Integer): Integer;
var
i: Integer;
begin
Result := 0;
for i := Index to Index + Count - 1 do
Result := Result + FTempArray[i];
end;
begin
n := Length(s);
if n = 0 then Exit;
spaceAr := nil;
FCanvas.Lock;
try
Style := C.Font.Style;
FHTMLTags.FDefStyle := Style;
FCanvas.Font.Style := Style;
FPPI := FDefPPI / FScrPPI;
PrnSz := FHTMLTags.FillCharSpacingArray(FTempArray, s, FCanvas, LineIndex,
Round(FCharSpacing * FPPI), False) - Round(FCharSpacing * FPPI);
Sz := FHTMLTags.FillCharSpacingArray(FTempArray, s, C, LineIndex,
Round(FCharSpacing * FScaleX), False) - Round(FCharSpacing * FScaleX); //!Den
C.Font.Style := Style;
if FHTMLTags.AllowTags and (FRotation <> 0) then
begin
SelectObject(C.Handle, oldfh);
DeleteObject(fh);
fh := CreateRotatedFont(C.Font, FRotation);
oldfh := SelectObject(C.Handle, fh);
end;
PPI := GetDeviceCaps(C.Handle, LOGPIXELSX);
ratio := FDefPPI / PPI;
if IsPrinter(C) then
neededSize := Round(prnSz * FPrintScale / ratio) else
neededSize := Round(prnSz / (FDefPPI / 96) * FScaleX);
if not FWysiwyg then
neededSize := Sz;
extraSize := neededSize - Sz;
CosA := Cos(pi / 180 * FRotation);
SinA := Sin(pi / 180 * FRotation);
if Align = haRight then
begin
X := x + Round((dx - neededSize + 1) * CosA);
Y := y - Round((dx - neededSize + 1) * SinA);
Dec(X, 1);
if (fsBold in Style) or (fsItalic in Style) then
if FRotation = 0 then
Dec(X, 1);
end
else if Align = haCenter then
begin
X := x + Round((dx - neededSize) / 2 * CosA);
Y := y - Round((dx - neededSize) / 2 * SinA);
end;
if Align = haBlock then
begin
GetMem(spaceAr, SizeOf(Integer) * n);
spaceCount := CountSpaces;
if spaceCount = 0 then
Align := haLeft else
extraSize := Abs(dx) - Sz;
end
else
spaceCount := 0;
if extraSize < 0 then
begin
extraSize := -extraSize;
add3 := -1;
end
else
add3 := 1;
if Align <> haBlock then
begin
if extraSize < n then
IncArray(FTempArray, 0, n - 1, extraSize, add3)
else
begin
add1 := extraSize div n * add3;
for i := 0 to n - 1 do
Inc(FTempArray[i], add1);
IncArray(FTempArray, 0, n - 1, extraSize - add1 * n * add3, add3)
end;
end
else
begin
add1 := extraSize div spaceCount;
add2 := extraSize mod spaceCount;
addCount := 0;
for i := 0 to n - 1 do
if spaceAr[i] = 1 then
begin
Inc(FTempArray[i], add1 * add3);
if addCount <= add2 then
begin
Inc(FTempArray[i], add3);
Inc(addCount);
end;
end;
end;
i := 0;
Tag := FHTMLTags[LineIndex].Items[0];
add1 := Round(Tag.AddY * Tag.Size * FScaleY);
repeat
j := i;
while i < n do
begin
Tag := FHTMLTags[LineIndex].Items[i];
if not Tag.Default then
begin
Tag.Default := True;
break;
end;
Inc(i);
end;
if (C.Font.Charset = DEFAULT_CHARSET) and (Win32Platform = VER_PLATFORM_WIN32_NT) then
if FWysiwyg then
ExtTextOutW(C.Handle, X + Round(add1 * SinA), Y + Round(add1 * CosA),
FOptions, @FScaledRect, PWideChar(s) + j, i - j, @FTempArray[j])
else
ExtTextOutW(C.Handle, X + Round(add1 * SinA), Y + Round(add1 * CosA),
FOptions, @FScaledRect, PWideChar(s) + j, i - j, nil)
else
if FWysiwyg then
ExtTextOut(C.Handle, X + Round(add1 * SinA), Y + Round(add1 * CosA),
FOptions, @FScaledRect, PChar(String(s)) + j, i - j, @FTempArray[j])
else
ExtTextOut(C.Handle, X + Round(add1 * SinA), Y + Round(add1 * CosA),
FOptions, @FScaledRect, PChar(String(s)) + j, i - j, nil);
if i < n then
begin
if IsPrinter(C) then
C.Font.Height := -Round(Tag.Size * PPI * FPrintScale / 72) else
C.Font.Height := -Round(Tag.Size * FScaleY * 96 / 72);
C.Font.Style := Tag.Style;
C.Font.Color := Tag.Color;
add1 := Round(Tag.AddY * Tag.Size * FScaleY);
cw := CalcWidth(j, i - j);
if FRotation = 0 then
X := X + cw
else
begin
X := X + Round(cw * CosA);
Y := Y - Round(cw * SinA);
SelectObject(C.Handle, oldfh);
DeleteObject(fh);
fh := CreateRotatedFont(C.Font, FRotation);
oldfh := SelectObject(C.Handle, fh);
end;
end;
until i >= n;
if spaceAr <> nil then
FreeMem(spaceAr, SizeOf(Integer) * n);
finally
FCanvas.Unlock;
end;
end;
procedure TfrxDrawText.DrawText(C: TCanvas; HAlign: TfrxHAlign; VAlign: TfrxVAlign);
var
Ar: PIntArray;
i, n, neededSize, extraSize, add1, add3: Integer;
ratio: Extended;
al: TfrxHAlign;
x, y, par: Integer;
Sz, prnSz: Integer;
Tag: TfrxHTMLTag;
fh, oldfh: HFont;
h, PPI, dx, gx: Integer;
CosA, SinA: Extended;
procedure CalcRotatedCoords;
var
AbsCosA, AbsSinA: Extended;
dy: Integer;
begin
CosA := Cos(pi / 180 * FRotation);
SinA := Sin(pi / 180 * FRotation);
AbsCosA := Abs(CosA);
AbsSinA := Abs(SinA);
dy := 0;
with FScaledRect do
case FRotation of
0:
begin
x := Left;
y := Top;
dx := Right - Left;
dy := Bottom - Top;
end;
1..89:
begin
x := Left;
dx := Round((Right - Left - neededsize * AbsSinA) / AbsCosA);
y := Top + Round(dx * AbsSinA);
dy := Bottom - y - Round(neededsize * AbsCosA) + neededsize;
CosA := 1; SinA := 0;
end;
90:
begin
x := Left;
y := Bottom;
dx := Bottom - Top;
dy := Right - Left;
end;
91..179:
begin
y := Bottom;
dx := Round((Right - Left - neededsize * AbsSinA) / AbsCosA);
x := Left + Round(dx * AbsCosA);
dy := Bottom - Top - Round(neededsize * AbsCosA + dx * AbsSinA) + neededsize;
CosA := -1; SinA := 0;
end;
180:
begin
x := Right;
y := Bottom;
dx := Right - Left;
dy := Bottom - Top;
end;
181..269:
begin
x := Right;
dx := Round((Right - Left - neededsize * AbsSinA) / AbsCosA);
y := Bottom - Round(dx * AbsSinA);
dy := y - Top - Round(neededsize * AbsCosA) + neededsize;
CosA := -1; SinA := 0;
end;
270:
begin
x := Right;
y := Top;
dx := Bottom - Top;
dy := Right - Left;
end;
271..359:
begin
y := Top;
dx := Round((Right - Left - neededsize * AbsSinA) / AbsCosA);
x := Left + Round(neededsize * AbsSinA);
dy := Bottom - Top - Round(dx * AbsSinA + neededsize * AbsCosA) + neededsize;
CosA := 1; SinA := 0;
end;
end;
if VAlign = vaBottom then
begin
y := y + Round(CosA * (dy - neededSize));
x := x + Round(SinA * (dy - neededSize));
end
else if VAlign = vaCenter then
begin
y := y + Round(CosA * (dy - neededSize) / 2);
x := x + Round(SinA * (dy - neededSize) / 2);
end;
CosA := cos(pi / 180 * FRotation);
SinA := sin(pi / 180 * FRotation);
end;
begin
n := FText.Count;
if (n = 0) or (FHTMLTags.Count = 0) then exit; // no text to draw
FCanvas.Lock;
try
PPI := GetDeviceCaps(C.Handle, LOGPIXELSY);
if IsPrinter(C) then
h := -Round(FFontSize * PPI * FPrintScale / 72) else
h := -Round(FFontSize * FScaleY * 96 / 72);
C.Font := FCanvas.Font;
C.Font.Height := h;
if FHTMLTags[0].Count > 0 then
begin
Tag := FHTMLTags[0].Items[0];
if not Tag.Default then
begin
C.Font.Style := Tag.Style;
C.Font.Color := Tag.Color;
if IsPrinter(C) then
C.Font.Height := -Round(Tag.Size * PPI * FPrintScale / 72) else
C.Font.Height := -Round(Tag.Size * FScaleY * 96 / 72);
end;
Tag.Default := True;
end;
fh := 0; oldfh := 0;
if FRotation <> 0 then
begin
fh := CreateRotatedFont(C.Font, FRotation);
oldfh := SelectObject(C.Handle, fh);
end;
Sz := -C.Font.Height;
PrnSz := -FCanvas.Font.Height;
if IsPrinter(C) then
begin
ratio := FDefPPI / PPI / FPrintScale;
neededSize := Round((prnSz * n + FLineSpacing * FScaleY * ratio * n) / ratio)
end
else
begin
ratio := FDefPPI / 96;
neededSize := Round((prnSz * n + FLineSpacing * ratio * n) / ratio * FScaleY);
end;
extraSize := neededSize - (Sz * n + Round(FLineSpacing * FScaleY) * n);
if not FWysiwyg then
extraSize := 0;
CalcRotatedCoords;
GetMem(Ar, SizeOf(Integer) * n);
for i := 0 to n - 2 do
Ar[i] := Round(FLineSpacing * FScaleY) + Sz;
if extraSize < 0 then
begin
extraSize := -extraSize;
add3 := -1;
end
else
add3 := 1;
if n > 1 then
if extraSize < n then
IncArray(Ar, 0, n - 2, extraSize, add3)
else if n > 1 then
begin
add1 := extraSize div (n - 1) * add3;
for i := 0 to n - 2 do
Inc(Ar[i], add1);
IncArray(Ar, 0, n - 2, extraSize - add1 * (n - 1) * add3, add3)
end;
SetBkMode(C.Handle, Transparent);
for i := 0 to n - 1 do
begin
gx := 0;
al := HAlign;
par := Integer(FText.Objects[i]);
if (par and 1) <> 0 then
if HAlign in [haLeft, haBlock] then
gx := Round(FParagraphGap * FScaleX);
if (par and 2) <> 0 then
if HAlign = haBlock then
if FRTLReading then
al := haRight else
al := haLeft;
DrawTextLine(C, FText[i], x + gx, y, dx - gx, i, al, fh, oldfh);
Inc(y, Round(Ar[i] * CosA));
Inc(x, Round(Ar[i] * SinA));
end;
FreeMem(Ar, SizeOf(Integer) * n);
if FRotation <> 0 then
begin
SelectObject(C.Handle, oldfh);
DeleteObject(fh);
end;
finally
FCanvas.Unlock;
end;
end;
function TfrxDrawText.UnusedSpace: Extended;
var
PrnSz: Integer;
n: Integer;
ratio: Extended;
begin
FCanvas.Lock;
try
PrnSz := -FCanvas.Font.Height;
ratio := FDefPPI / FScrPPI;
// number of lines that will fit in the bounds
n := Trunc((FOriginalRect.Bottom - FOriginalRect.Top + 1) /
(PrnSz / ratio + FLineSpacing));
if n = 0 then
Result := 0
else
begin
Result := (FOriginalRect.Bottom - FOriginalRect.Top + 1) -
(PrnSz / ratio + FLineSpacing) * n;
if Result = 0 then
Result := 1e-4;
end;
finally
FCanvas.Unlock;
end;
end;
function TfrxDrawText.CalcHeight: Extended;
var
PrnSz: Integer;
n: Integer;
ratio: Extended;
begin
n := FText.Count;
if n = 0 then
begin
Result := 0;
Exit;
end;
FCanvas.Lock;
try
PrnSz := -FCanvas.Font.Height;
finally
FCanvas.Unlock;
end;
ratio := FDefPPI / FScrPPI;
Result := (PrnSz / ratio + FLineSpacing) * n;
end;
function TfrxDrawText.CalcWidth: Extended;
var
Sz: TSize;
s: WideString;
i, maxWidth, par: Integer;
ratio: Extended;
begin
if FText.Count = 0 then
begin
Result := 0;
Exit;
end;
ratio := FDefPPI / FScrPPI;
maxWidth := 0;
FCanvas.Lock;
try
for i := 0 to FText.Count - 1 do
begin
s := FText[i];
GetTextExtentPointW(FCanvas.Handle, PWideChar(s), Length(s), Sz);
Inc(Sz.cx, Round(Length(s) * FCharSpacing * ratio));
par := Integer(FText.Objects[i]);
if (par and 1) <> 0 then
Inc(Sz.cx, Round(FParagraphGap * ratio));
if maxWidth < Sz.cx then
maxWidth := Sz.cx;
end;
finally
FCanvas.Unlock;
end;
Result := maxWidth / ratio;
end;
function TfrxDrawText.LineHeight: Extended;
var
PrnSz: Integer;
ratio: Extended;
begin
FCanvas.Lock;
try
PrnSz := -FCanvas.Font.Height;
finally
FCanvas.Unlock;
end;
ratio := FDefPPI / FScrPPI;
Result := PrnSz / ratio + FLineSpacing;
end;
function TfrxDrawText.GetOutBoundsText(var ParaBreak: Boolean): WideString;
var
PrnSz: Integer;
n, vl: Integer;
ratio: Extended;
Tag: TfrxHTMLTags;
cl: LongInt;
begin
ParaBreak := False;
Result := '';
n := FText.Count;
if n = 0 then Exit;
FCanvas.Lock;
try
PrnSz := -FCanvas.Font.Height;
ratio := FDefPPI / FScrPPI;
// number of lines that will fit in the bounds
vl := Trunc((FOriginalRect.Bottom - FOriginalRect.Top + 1) / (PrnSz / ratio + FLineSpacing));
if vl > n then
vl := n;
if vl < FHTMLTags.Count then
begin
// deleting all outbounds text
while FText.Count > vl do
FText.Delete(FText.Count - 1);
if Integer(FText.Objects[vl - 1]) in [0, 1] then
ParaBreak := True;
Tag := FHTMLTags[vl];
Result := Copy(FPlainText, Tag[0].Position, Length(FPlainText) - Tag[0].Position + 1);
if ParaBreak then
if (Length(Result) > 0) and (Result[1] = ' ') then
Delete(Result, 1, 1);
Delete(FPlainText, Tag[0].Position, Length(FPlainText) - Tag[0].Position + 1);
if FHTMLTags.AllowTags then
begin
if fsBold in Tag[0].Style then
Result := '<b>' + Result;
if fsItalic in Tag[0].Style then
Result := '<i>' + Result;
if fsUnderline in Tag[0].Style then
Result := '<u>' + Result;
cl := ColorToRGB(Tag[0].Color);
cl := (cl and $00FF0000) div 65536 + (cl and $000000FF) * 65536 + (cl and $0000FF00);
Result := '<font color="#' + IntToHex(cl, 6) + '">' + Result;
end;
end;
finally
FCanvas.Unlock;
end;
end;
function TfrxDrawText.GetInBoundsText: WideString;
begin
Result := FPlainText;
end;
function TfrxDrawText.IsPrinter(C: TCanvas): Boolean;
begin
Result := C is TfrxPrinterCanvas;
end;
procedure TfrxDrawText.Lock;
begin
while FLocked do
Application.ProcessMessages;
FLocked := True;
end;
procedure TfrxDrawText.Unlock;
begin
FLocked := False;
end;
function TfrxDrawText.GetWrappedText: WideString;
begin
Result := FText.Text;
end;
function TfrxDrawText.TextHeight: Extended;
var
PrnSz: Integer;
ratio: Extended;
begin
FCanvas.Lock;
try
PrnSz := -FCanvas.Font.Height;
finally
FCanvas.Unlock;
end;
ratio := FDefPPI / FScrPPI;
Result := PrnSz / ratio;
end;
initialization
frxDrawText := TfrxDrawText.Create;
finalization
frxDrawText.Free;
end.
//862fd5d6aa1a637203d9b08a3c0bcfb0
Reference in New Issue View Git Blame Copy Permalink