2184 lines
55 KiB
ObjectPascal
2184 lines
55 KiB
ObjectPascal
|
|
{******************************************}
|
|
{ }
|
|
{ FastReport VCL }
|
|
{ HTML <div> Export }
|
|
{ }
|
|
{ Copyright (c) 1998-2021 }
|
|
{ by Fast Reports Inc. }
|
|
{ }
|
|
{******************************************}
|
|
|
|
unit frxExportHTMLDiv;
|
|
|
|
{ General advice for using this export.
|
|
|
|
• Avoid using vertical alignment in memos:
|
|
it forces the export to create more
|
|
complicated HTML. Leave the alignment vaTop
|
|
whenever it's possible.
|
|
|
|
• Use @-type anchors in TfrxView.URL instead of
|
|
#-type, because #-type is much slower to export. }
|
|
|
|
interface
|
|
|
|
{$I frx.inc}
|
|
|
|
uses
|
|
{$IFNDEF FPC}
|
|
Windows,
|
|
{$ENDIF}
|
|
SysUtils,
|
|
Variants,
|
|
Classes,
|
|
{$IFDEF FPC}
|
|
LCLType, LCLIntf, LCLProc,
|
|
{$ENDIF}
|
|
{$IFNDEF FPC}
|
|
ShellAPI,
|
|
{$ENDIF}
|
|
Graphics,
|
|
frxClass,
|
|
frxBaseGraphicsTypes,
|
|
frxStorage, // for TCachedStream
|
|
frxGradient,
|
|
{$IFDEF DELPHI16}
|
|
System.UITypes,
|
|
{$ENDIF}
|
|
frxExportHelpers, frxExportBaseDialog, frxVectorCanvas, frxCSSStyle;
|
|
|
|
type
|
|
{ Measures actual size of a TfrxView.
|
|
Example:
|
|
|
|
Gauge := TfrxBoundsGauge.Create;
|
|
Gauge.Obj := MemoView;
|
|
|
|
Gauge.Bounds.Left; // the leftmost coordinate including the left border
|
|
Gauge.Borders.Left; // the left border width }
|
|
|
|
TfrxBoundsGauge = class
|
|
private
|
|
FObj: TfrxView;
|
|
FBoundsSet: Boolean;
|
|
FBounds: TRect;
|
|
FBorders: TRect;
|
|
|
|
FX, FY, FX1, FY1, FDX, FDY: Integer;
|
|
FFrameWidth: Integer;
|
|
|
|
procedure SetObj(Obj: TfrxView);
|
|
procedure AddBounds(r: TRect);
|
|
function GetInnerWidth: Integer;
|
|
function GetInnerHeight: Integer;
|
|
protected
|
|
procedure BeginDraw;
|
|
procedure DrawBackground;
|
|
procedure DrawFrame;
|
|
procedure DrawLine(x1, y1, x2, y2, w: Integer; Side: TfrxFrameType);
|
|
public
|
|
property Obj: TfrxView read FObj write SetObj;
|
|
property Bounds: TRect read FBounds;
|
|
property Borders: TRect read FBorders;
|
|
property InnerWidth: Integer read GetInnerWidth;
|
|
property InnerHeight: Integer read GetInnerHeight;
|
|
end;
|
|
|
|
{ Represents a HTML tag }
|
|
|
|
TfrxHTMLItem = class
|
|
private
|
|
FName: string;
|
|
FKeys: TStrings;
|
|
FValues: TStrings;
|
|
FValue: string;
|
|
FRawValue: AnsiString;
|
|
FChildren: TObjList;
|
|
FLeft, FTop, FWidth, FHeight: Extended;
|
|
FLeftSet, FTopSet, FWidthSet, FHeightSet: Boolean;
|
|
FStyle: TfrxCSSStyle;
|
|
FClass: string;
|
|
FRotation: Integer;
|
|
FAllowNegativeLeft: Boolean;
|
|
FIsTransformMatrix: Boolean;
|
|
FTM: array of Extended; // TransformMatrix
|
|
|
|
procedure SetProp(Index: string; const Value: string);
|
|
function GetProp(Index: string): string;
|
|
function GetStyle: TfrxCSSStyle;
|
|
|
|
procedure SetLeft(a: Extended);
|
|
procedure SetTop(a: Extended);
|
|
procedure SetWidth(a: Extended);
|
|
procedure SetHeight(a: Extended);
|
|
public
|
|
|
|
constructor Create(const Name: string);
|
|
destructor Destroy; override;
|
|
|
|
function This: TfrxHTMLItem;
|
|
|
|
procedure GaudeFrame(Obj: TfrxView);
|
|
procedure Gaude(Obj: TfrxView);
|
|
procedure WidenBy(Size: Extended);
|
|
procedure DoPositive;
|
|
|
|
class function EscapeAttribute(const s: string): string;
|
|
|
|
procedure Save(Stream: TStream; Formatted: Boolean);
|
|
|
|
function Add(const Tag: string): TfrxHTMLItem; overload;
|
|
function Add(Item: TfrxHTMLItem): TfrxHTMLItem; overload;
|
|
function AddRotated(const Tag: string; ARotation: Integer): TfrxHTMLItem;
|
|
function AddTransformed(const Tag: string; ATransformMatrix: array of Extended): TfrxHTMLItem;
|
|
procedure AddCSSClass(const s: string);
|
|
|
|
property Prop[Index: string]: string read GetProp write SetProp; default;
|
|
property Value: string write FValue;
|
|
property RawValue: AnsiString write FRawValue;
|
|
property Name: string write FName;
|
|
|
|
{ CSS style is created on demand }
|
|
property Style: TfrxCSSStyle read GetStyle;
|
|
{ These lengths are measured in FR units (pixels) }
|
|
property Left: Extended read FLeft write SetLeft;
|
|
property Top: Extended read FTop write SetTop;
|
|
property Width: Extended read FWidth write SetWidth;
|
|
property Height: Extended read FHeight write SetHeight;
|
|
|
|
property AllowNegativeLeft: Boolean read FAllowNegativeLeft write FAllowNegativeLeft;
|
|
end;
|
|
|
|
{ Queue of automatically serialised HTML tags }
|
|
|
|
TfrxHTMLItemQueue = class
|
|
private
|
|
FQueue: array of TfrxHTMLItem;
|
|
FUsed: Integer;
|
|
FStream: TStream;
|
|
FFormatted: Boolean;
|
|
protected
|
|
procedure Flush;
|
|
public
|
|
constructor Create(Stream: TStream; Formatted: Boolean);
|
|
destructor Destroy; override;
|
|
|
|
procedure Push(Item: TfrxHTMLItem);
|
|
procedure SetQueueLength(n: Integer);
|
|
end;
|
|
|
|
{ HTML export filter }
|
|
|
|
{$IFDEF DELPHI16}
|
|
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
|
|
{$ENDIF}
|
|
|
|
TfrxHTMLDivExport = class(TExportHTMLDivSVGParent)
|
|
private
|
|
FTitle: string;
|
|
FHTML5: Boolean;
|
|
FAllPictures: Boolean;
|
|
FPageStyle: TfrxCSSStyle;
|
|
FExportAnchors: Boolean;
|
|
FPictureTag: Integer;
|
|
|
|
FQueue: TfrxHTMLItemQueue; // it represents the current page
|
|
|
|
FUseTemplates: Boolean;
|
|
FPrint: Boolean;
|
|
FGetNavTemplate: TfrxHTMLExportGetNavTemplate;
|
|
FGetMainTemplate: TfrxHTMLExportGetMainTemplate;
|
|
FGetToolbarTemplate: TfrxHTMLExportGetToolbarTemplate;
|
|
|
|
FPreviewOutline: TfrxCustomOutline;
|
|
FOutlineTree: TfrxHTMLOutlineNode;
|
|
FOutlineTreeNode :TfrxHTMLOutlineNode;
|
|
|
|
FOnProcessHyperLink: TOnProcessHyperLink;
|
|
FParentDetailURL: String;
|
|
|
|
function GetPageStyle: TfrxCSSStyle;
|
|
function GetAnchor(var Page: string; const Name: string): Boolean;
|
|
function GetHRef(const URL: string): string;
|
|
procedure PutImg(Obj: TfrxView; Pic: TGraphic; WriteSize: Boolean);
|
|
procedure EndHTML;
|
|
|
|
{ Handlers for specific kinds of TfrxView objects.
|
|
They return "True" if they succeed to export an object, or "False"
|
|
if they want to pass the object further along the handlers chain. }
|
|
function ExportTaggedView(Obj: TfrxView): Boolean;
|
|
function ExportAllPictures(Obj: TfrxView): Boolean;
|
|
function ExportMemo(Obj: TfrxView): Boolean;
|
|
function ExportPicture(Obj: TfrxView): Boolean;
|
|
function ExportShape(Obj: TfrxView): Boolean;
|
|
function ExportLine(Obj: TfrxView): Boolean;
|
|
function ExportGradient(Obj: TfrxView): Boolean;
|
|
{$IFNDEF FPC}
|
|
function ExportViaEMF(Obj: TfrxView): Boolean;
|
|
{$ENDIF}
|
|
function ExportAsPicture(Obj: TfrxView): Boolean;
|
|
protected
|
|
{ Creates a new HTML tag and returns it. The tag don't need to be
|
|
deleted or serialised to a stream: this is done automatically. }
|
|
function AddTag(const Name: string): TfrxHTMLItem;
|
|
{ Creates an empty <div> tag with assigned styles }
|
|
function CreateDiv(Obj: TfrxView; Widen: Integer = 0): TfrxHTMLItem;
|
|
function CreateFrameDiv(Obj: TfrxView): TfrxHTMLItem;
|
|
function CreateFillDiv(Obj: TfrxView): TfrxHTMLItem;
|
|
procedure FillGraduienProps(Style: TfrxCSSStyle;
|
|
BeginColor, EndColor: TColor; GradientStyle: TfrxGradientStyle);
|
|
function FilterHTML(const Text: string): string;
|
|
function EscapeText(const s: string): string;
|
|
|
|
function DoHyperLink(HL: TfrxHyperlink): string;
|
|
procedure DoExportAsPicture(Obj: TfrxView; Transparent: Boolean; IsVectorSource: Boolean; IsAlphaSource: Boolean;
|
|
TransparentColor: TColor = clNone);
|
|
|
|
function NavPageNumber(PageNumber: Integer): string;
|
|
procedure StartAnchors;
|
|
procedure StartNavigator;
|
|
procedure CreateCSS; override;
|
|
procedure StartHTML;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
|
|
class function GetDescription: String; override;
|
|
class function ExportDialogClass: TfrxBaseExportDialogClass; override;
|
|
{ function ShowModal: TModalResult; override; }
|
|
|
|
function Start: Boolean; override;
|
|
procedure StartPage(Page: TfrxReportPage; Index: Integer); override;
|
|
procedure FinishPage(Page: TfrxReportPage; Index: Integer); override;
|
|
procedure Finish; override;
|
|
|
|
{ Report pages are represented as separate <div> tags. All these tags
|
|
are associated with the same CSS style, so its possible to adjust
|
|
appearance of pages by modifying this style. Example:
|
|
|
|
PageStyle['border'] := '1mm solid orange';
|
|
PageStyle['margin'] := '5mm';
|
|
PageStyle.CSS3Style['box-shadow'] := '3mm 3mm 3mm gray';
|
|
PageStyle.cSS3Style['border-radius'] := '3mm'; }
|
|
property PageStyle: TfrxCSSStyle read GetPageStyle;
|
|
|
|
property OnProcessHyperLink: TOnProcessHyperLink read FOnProcessHyperLink write FOnProcessHyperLink;
|
|
property ParentDetailURL: String read FParentDetailURL write FParentDetailURL;
|
|
|
|
property Print: Boolean read FPrint write FPrint;
|
|
property UseTemplates: Boolean read FUseTemplates write FUseTemplates;
|
|
property OnGetMainTemplate: TfrxHTMLExportGetMainTemplate read FGetMainTemplate
|
|
write FGetMainTemplate;
|
|
property OnGetToolbarTemplate: TfrxHTMLExportGetToolbarTemplate read FGetToolbarTemplate
|
|
write FGetToolbarTemplate;
|
|
property OnGetNavTemplate: TfrxHTMLExportGetNavTemplate read FGetNavTemplate
|
|
write FGetNavTemplate;
|
|
published
|
|
property Title: string read FTitle write FTitle;
|
|
|
|
{ Allows using HTML5 features }
|
|
property HTML5: Boolean read FHTML5 write FHTML5;
|
|
|
|
{ Exports all report components as pictures }
|
|
property AllPictures: Boolean read FAllPictures write FAllPictures;
|
|
|
|
{ Creates anchors based on TfrxView.URL property. This option is useful only if
|
|
the URLs begin with the "#" sign. }
|
|
property ExportAnchors: Boolean read FExportAnchors write FExportAnchors;
|
|
|
|
{ If not equals zero, forces the export to save all report components
|
|
with this value of the Tag property export as pictures. The format of pictures
|
|
is defined by PictureFormat. }
|
|
property PictureTag: Integer read FPictureTag write FPictureTag;
|
|
end;
|
|
|
|
{ HTML export that uses modern HTML5 features }
|
|
{$IFDEF DELPHI16}
|
|
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
|
|
{$ENDIF}
|
|
|
|
TfrxHTML5DivExport = class(TfrxHTMLDivExport)
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
class function GetDescription: String; override;
|
|
end;
|
|
|
|
{ HTML export that is compatible with old browsers, like IE6 }
|
|
{$IFDEF DELPHI16}
|
|
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
|
|
{$ENDIF}
|
|
|
|
TfrxHTML4DivExport = class(TfrxHTMLDivExport)
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
class function GetDescription: String; override;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
Contnrs,
|
|
frxUtils,
|
|
frxRes,
|
|
Math,
|
|
frxXML, // for access to TfrxPreviewPages.FindAnchor's results
|
|
frxPreviewPages,
|
|
{$IFNDEF FPC}frxEMFtoSVGExport, frxEMFAbstractExport, {$ENDIF}
|
|
frxExportHTMLDivDialog;
|
|
|
|
const
|
|
wbFrame = 1;
|
|
wbExport = 2;
|
|
|
|
{ Utility routines }
|
|
|
|
function FRLength(a: Extended; AllowNegative: Boolean = False): string;
|
|
var
|
|
ra: Integer;
|
|
begin
|
|
ra := Round(a);
|
|
Result := IfStr(not AllowNegative and (ra <= 0), '0', IntToStr(ra) + 'px');
|
|
end;
|
|
|
|
function GetLineStyle(s: TfrxFrameStyle): string;
|
|
begin
|
|
case s of
|
|
fsSolid:
|
|
Result := 'solid';
|
|
fsDash:
|
|
Result := 'dashed';
|
|
fsDot:
|
|
Result := 'dotted';
|
|
fsDashDot:
|
|
Result := 'dashed';
|
|
fsDashDotDot:
|
|
Result := 'dotted';
|
|
fsDouble:
|
|
Result := 'double';
|
|
fsAltDot:
|
|
Result := 'dotted';
|
|
fsSquare:
|
|
Result := 'dotted';
|
|
else
|
|
Result := '';
|
|
end;
|
|
end;
|
|
|
|
function GetFrameLineStyle(w: Extended; s: TfrxFrameStyle; c: TColor): string; overload;
|
|
begin
|
|
if Round(w) = 0 then
|
|
Result := ''
|
|
else
|
|
Result := FRLength(Max(w, 1.0)) + ' ' + GetLineStyle(s) + ' ' + GetColor(c)
|
|
end;
|
|
|
|
function GetFrameLineStyle(Line: TfrxFrameLine): string; overload;
|
|
begin
|
|
Result := GetFrameLineStyle(Line.Width, Line.Style, Line.Color)
|
|
end;
|
|
|
|
function GetHAlign(Align: TfrxHAlign): string;
|
|
begin
|
|
case Align of
|
|
haRight:
|
|
Result := 'right';
|
|
haCenter:
|
|
Result := 'center';
|
|
haBlock:
|
|
Result := 'justify';
|
|
else
|
|
Result := '';
|
|
end;
|
|
end;
|
|
|
|
function GetVAlign(Align: TfrxVAlign): string;
|
|
begin
|
|
case Align of
|
|
vaTop:
|
|
Result := 'top';
|
|
vaBottom:
|
|
Result := 'bottom';
|
|
vaCenter:
|
|
Result := 'middle';
|
|
else
|
|
Result := '';
|
|
end;
|
|
end;
|
|
|
|
function GetFont(Font: TFont): string;
|
|
begin
|
|
Result := IfStr(fsBold in Font.Style, 'bold ') + IfStr(fsItalic in Font.Style,
|
|
'italic ') + IntToStr(Font.Size) + 'pt ' + Font.Name
|
|
end;
|
|
|
|
function GetTextDecoration(s: TFontStyles): string;
|
|
begin
|
|
Result := IfStr(fsUnderline in s, 'underline ') + IfStr(fsStrikeOut in s,
|
|
'line-through')
|
|
end;
|
|
|
|
{ TfrxHTMLDivExport }
|
|
|
|
function TfrxHTMLDivExport.AddTag(const Name: string): TfrxHTMLItem;
|
|
begin
|
|
Result := TfrxHTMLItem.Create(Name);
|
|
FQueue.Push(Result);
|
|
end;
|
|
|
|
constructor TfrxHTMLDivExport.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
DefaultExt := GetStr('HTMLExtension');
|
|
FilterDesc := frxGet(9301);
|
|
{ LIFO }
|
|
AttachHandler(ExportAsPicture);
|
|
AttachHandler(ExportPicture);
|
|
{$IFNDEF FPC}
|
|
AttachHandler(ExportViaEMF);
|
|
{$ENDIF}
|
|
AttachHandler(ExportGradient);
|
|
AttachHandler(ExportLine);
|
|
AttachHandler(ExportShape); // Without Fill (except skRectangle)
|
|
AttachHandler(ExportMemo);
|
|
AttachHandler(ExportAllPictures);
|
|
AttachHandler(ExportTaggedView);
|
|
Server := False;
|
|
FUseTemplates := False;
|
|
FPrint := false;
|
|
FOnProcessHyperLink := nil;
|
|
end;
|
|
|
|
procedure TfrxHTMLDivExport.CreateCSS;
|
|
begin
|
|
inherited;
|
|
|
|
FCSS := TfrxCSSList.Create;
|
|
|
|
with FCSS do
|
|
begin
|
|
AddName('div, img, table')['position'] := 'absolute';
|
|
AddName('div, td')['overflow'] := 'hidden';
|
|
|
|
AddName('sub')['font-size'] := '0.67em';
|
|
|
|
with AddName('sup') do
|
|
begin
|
|
Style['font-size'] := '0.67em';
|
|
Style['vertical-align'] := 'top';
|
|
Style['position'] := 'relative';
|
|
Style['top'] := '-0.2em';
|
|
end;
|
|
|
|
AddName('svg')['vertical-align'] := 'top';
|
|
|
|
with AddName('tr, td, table, tbody') do
|
|
begin
|
|
Style['text-decoration'] := 'inherit';
|
|
Style['vertical-align'] := 'inherit';
|
|
end;
|
|
|
|
with AddName('table') do
|
|
begin
|
|
Style['width'] := '100%';
|
|
Style['height'] := '100%';
|
|
Style['border-spacing'] := '0';
|
|
if not HTML5 then
|
|
begin
|
|
Style['border'] := '0';
|
|
Style['padding'] := '0';
|
|
end;
|
|
end;
|
|
|
|
// AddName('img')['z-index'] := '1';
|
|
|
|
with AddName('.nav') do
|
|
begin
|
|
Style['font-family'] := 'Courier New, monospace';
|
|
Style['font-size'] := '16';
|
|
Style['font-weight'] := 'bold';
|
|
Style['margin'] := '1em';
|
|
end;
|
|
|
|
with AddName('.nav a') do
|
|
begin
|
|
Style['text-decoration'] := 'none';
|
|
Style['margin-right'] := '1em';
|
|
Style['color'] := 'black';
|
|
end;
|
|
|
|
AddName('.nav a:hover')['text-decoration'] := 'underline';
|
|
|
|
if FPageStyle <> nil then
|
|
FPageStyle.AssignTo(AddName('.page'));
|
|
if Outline then
|
|
AddName(outlineCSS);
|
|
end;
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.CreateDiv(Obj: TfrxView; Widen: Integer = 0): TfrxHTMLItem;
|
|
var
|
|
rBounds: TfrxRect;
|
|
begin
|
|
Result := AddTag('div');
|
|
Result.Gaude(Obj);
|
|
Result.DoPositive;
|
|
if Widen = wbFrame then
|
|
Result.WidenBy(Obj.Frame.Width)
|
|
else if Widen = wbExport then
|
|
begin
|
|
Result.AllowNegativeLeft := True;
|
|
rBounds := Obj.GetExportBounds;
|
|
Result.Left := rBounds.Left;
|
|
Result.Width := rBounds.Right - rBounds.Left;
|
|
Result.Top := rBounds.Top;
|
|
Result.Height := rBounds.Bottom - rBounds.Top;
|
|
if Obj is TfrxCustomMemoView then
|
|
with TfrxCustomMemoView(Obj) do
|
|
if not Clipped and (Page <> nil) and (Page is TfrxReportPage) then
|
|
begin
|
|
Result.Left := Min(Result.Left, 0);
|
|
Result.Top := Min(Result.Top, 0);
|
|
Result.Width := Max(Result.Width, Page.Width);
|
|
Result.Height := Max(Result.Height, Page.Height);
|
|
end;
|
|
end;
|
|
|
|
if Obj.ShowHint then
|
|
Result.Prop['title'] := Obj.Hint;
|
|
with Result do
|
|
if Obj.URL <> '' then
|
|
with Add('a') do
|
|
begin
|
|
Style['width'] := '100%';
|
|
Style['height'] := '100%';
|
|
Style['position'] := 'absolute';
|
|
|
|
Prop['href'] := GetHRef(Obj.URL);
|
|
end;
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.CreateFillDiv(Obj: TfrxView): TfrxHTMLItem;
|
|
|
|
function SVGPatternFill(XLine, YLine, Turn: Boolean; Color: TColor;
|
|
Width, Height: Integer; LineWidth: Extended): string;
|
|
var
|
|
PatternName: string;
|
|
begin
|
|
PatternName := SVGUniqueID;
|
|
with TTextFragment.Create(Formatted) do
|
|
begin
|
|
Add('<svg width="100%" height="100%">');
|
|
|
|
Add(SVGPattern(Formatted, XLine, YLine, Turn, Color, LineWidth,
|
|
PatternName));
|
|
|
|
Add('<rect width="%u" height="%u" fill="url(#%s)" />',
|
|
[Width, Height, PatternName]);
|
|
|
|
Add('</svg>');
|
|
|
|
Result := Text;
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
Width, Height: Integer;
|
|
|
|
function PF(LineColor: TColor; XLine, YLine, Turn: Boolean): string;
|
|
begin
|
|
PF := SVGPatternFill(XLine, YLine, Turn, LineColor, Width, Height, 1.4);
|
|
end;
|
|
|
|
var
|
|
x, y, w2, h2: Integer;
|
|
begin
|
|
Result := nil;
|
|
if (Obj.FillType = ftBrush) and
|
|
(TfrxBrushFill(Obj.Fill).Style in [bsSolid, bsClear]) and
|
|
(TfrxBrushFill(Obj.Fill).BackColor = clNone) { transparent brush } or
|
|
(Obj.FillType = ftGlass) and (TfrxGlassFill(Obj.Fill).Color = clNone)
|
|
{ transparent glass } then
|
|
Exit;
|
|
|
|
Result := AddTag('div');
|
|
Result.Gaude(Obj);
|
|
|
|
Width := Round(Result.Width);
|
|
Height := Round(Result.Height);
|
|
case Obj.FillType of
|
|
ftBrush:
|
|
with TfrxBrushFill(Obj.Fill) do
|
|
begin
|
|
with TfrxCSSStyle.Create do
|
|
begin
|
|
Style['background'] := GetColor(BackColor);
|
|
Result.AddCSSClass(LockStyle(This));
|
|
end;
|
|
|
|
case Style of
|
|
bsHorizontal:
|
|
Result.Value := PF(ForeColor, True, False, False);
|
|
bsVertical:
|
|
Result.Value := PF(ForeColor, False, True, False);
|
|
bsFDiagonal:
|
|
Result.Value := PF(ForeColor, True, False, True);
|
|
bsBDiagonal:
|
|
Result.Value := PF(ForeColor, False, True, True);
|
|
bsCross:
|
|
Result.Value := PF(ForeColor, True, True, False);
|
|
bsDiagCross:
|
|
Result.Value := PF(ForeColor, True, True, True);
|
|
else // bsSolid, bsClear:
|
|
end;
|
|
end;
|
|
ftGradient:
|
|
with TfrxGradientFill(Obj.Fill) do
|
|
with TfrxCSSStyle.Create do
|
|
begin
|
|
FillGraduienProps(This, StartColor, EndColor,
|
|
TfrxGradientStyle(GradientStyle));
|
|
Result.AddCSSClass(LockStyle(This));
|
|
end;
|
|
ftGlass:
|
|
with TfrxGlassFill(Obj.Fill) do
|
|
begin
|
|
with TfrxCSSStyle.Create do
|
|
begin
|
|
Style['background'] := frxExportHelpers.GetColor(Color);
|
|
Result.AddCSSClass(LockStyle(This));
|
|
end;
|
|
x := 0;
|
|
y := 0;
|
|
w2 := Width;
|
|
h2 := Height;
|
|
CalcGlassRect(Orientation, 0, 0, x, y, w2, h2);
|
|
with TTextFragment.Create(Formatted) do
|
|
begin
|
|
Add('<svg width="100%" height="100%">');
|
|
Add('<rect x="%d" y="%d" width="%u" height="%u" fill="%s" />',
|
|
[x, y, w2, h2, frxExportHelpers.GetColor(BlendColor)]);
|
|
if Hatch then
|
|
Add(PF(HatchColor, False, True, True));
|
|
Add('</svg>');
|
|
Result.Value := Text;
|
|
Free;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.CreateFrameDiv(Obj: TfrxView): TfrxHTMLItem;
|
|
|
|
procedure FillFrameProps(Style: TfrxCSSStyle; Frame: TfrxFrame);
|
|
var
|
|
L, T, r, B: string;
|
|
begin
|
|
L := IfStr(ftLeft in Frame.Typ, GetFrameLineStyle(Frame.LeftLine));
|
|
T := IfStr(ftTop in Frame.Typ, GetFrameLineStyle(Frame.TopLine));
|
|
r := IfStr(ftRight in Frame.Typ, GetFrameLineStyle(Frame.RightLine));
|
|
B := IfStr(ftBottom in Frame.Typ, GetFrameLineStyle(Frame.BottomLine));
|
|
|
|
if (L = T) and (L = r) and (L = B) then
|
|
Style['border'] := L
|
|
else
|
|
begin
|
|
Style['border-left'] := L;
|
|
Style['border-top'] := T;
|
|
Style['border-right'] := r;
|
|
Style['border-bottom'] := B;
|
|
end;
|
|
|
|
if Frame.DropShadow and HTML5 then
|
|
with Style do
|
|
PrefixStyle['box-shadow'] := FRLength(Frame.ShadowWidth) + ' ' +
|
|
FRLength(Frame.ShadowWidth) + ' ' + FRLength(Frame.ShadowWidth) + ' '
|
|
+ GetColor(Frame.ShadowColor);
|
|
end;
|
|
|
|
begin
|
|
Result := nil;
|
|
if (Obj.Frame.Typ = []) and not(Obj.Frame.DropShadow and HTML5) then
|
|
Exit;
|
|
Result := AddTag('div');
|
|
|
|
Result.GaudeFrame(Obj);
|
|
|
|
with TfrxCSSStyle.Create do
|
|
begin
|
|
FillFrameProps(This, Obj.Frame);
|
|
Result.AddCSSClass(LockStyle(This));
|
|
end;
|
|
|
|
end;
|
|
|
|
destructor TfrxHTMLDivExport.Destroy;
|
|
begin
|
|
FPageStyle.Free; // it's created by the getter of PageStyle
|
|
inherited
|
|
end;
|
|
|
|
procedure TfrxHTMLDivExport.DoExportAsPicture(Obj: TfrxView; Transparent: Boolean; IsVectorSource: Boolean; IsAlphaSource: Boolean; TransparentColor: TColor = clNone);
|
|
var
|
|
Pic: TfrxPicture;
|
|
PF: TfrxPictureFormat;
|
|
Correction: Integer;
|
|
begin
|
|
if Transparent then
|
|
PF := pfPNG
|
|
else
|
|
PF := PictureFormat;
|
|
|
|
Correction := IfInt(Obj is TfrxShapeView, 2);
|
|
|
|
{ Some objects can have negative dimensions }
|
|
Pic := TfrxPicture.Create(PF, Abs(Round(Obj.AbsLeft + Obj.Width) -
|
|
Round(Obj.AbsLeft)) + Correction,
|
|
Abs(Round(Obj.AbsTop + Obj.Height) - Round(Obj.AbsTop)) + Correction, Transparent, IsVectorSource, IsAlphaSource);
|
|
|
|
if Transparent and (TransparentColor <> clNone) then
|
|
begin
|
|
Pic.SetTransparentColor(TransparentColor);
|
|
Pic.FillColor(TransparentColor);
|
|
end
|
|
else
|
|
Pic.FillColor(Obj.Color);
|
|
Obj.DrawClipped(Pic.Canvas, 1, 1, -Obj.AbsLeft, -Obj.AbsTop);
|
|
|
|
PutImg(Obj, Pic.Release, False);
|
|
Pic.Free;
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.DoHyperLink(HL: TfrxHyperlink): string;
|
|
|
|
function FileByAnchor: string;
|
|
begin
|
|
Result := IntToStr((Report.PreviewPages as TfrxPreviewPages)
|
|
.GetAnchorPage(HL.Value)) + DefaultExt;
|
|
end;
|
|
|
|
var
|
|
OHV: string;
|
|
|
|
begin
|
|
Result := '';
|
|
if (HL <> nil) then
|
|
begin
|
|
if (@FOnProcessHyperLink <> nil) then
|
|
begin
|
|
OHV := FOnProcessHyperLink(HL, FParentDetailURL);
|
|
if (OHV <> '') then
|
|
Result := Format('<a href="%s">', [OHV]);
|
|
end;
|
|
if (OHV = '') then
|
|
begin
|
|
OHV := TfrxHTMLItem.EscapeAttribute(HL.Value);
|
|
if OHV <> '' then
|
|
case HL.Kind of
|
|
hkURL:
|
|
Result := Format('<a href="%s" target="_blank">', [OHV]);
|
|
hkAnchor:
|
|
if MultiPage then
|
|
Result := Format('<a href="%s#%s">', [FileByAnchor, OHV])
|
|
else
|
|
Result := Format('<a href="#%s">', [OHV]);
|
|
hkPageNumber:
|
|
if MultiPage then
|
|
Result := Format('<a href="%s">', [OHV + DefaultExt])
|
|
else
|
|
Result := Format('<a href="#page%s">', [OHV]);
|
|
else { hkDetailReport:, hkDetailPage:, hkCustom: }
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxHTMLDivExport.EndHTML;
|
|
begin
|
|
{ <style> can only appear inside <head>, but there's no other way
|
|
to embed styles and this approach works perfectly for all browsers. }
|
|
if Outline then
|
|
begin
|
|
Puts('</div>');
|
|
Puts(outlineJS);
|
|
end;
|
|
if EmbeddedCSS then
|
|
begin
|
|
Puts('<style>');
|
|
FCSS.Save(FCurrentFile, Formatted);
|
|
Puts('</style>');
|
|
end;
|
|
if not Server then
|
|
begin
|
|
Puts('</body>');
|
|
Puts('</html>');
|
|
end;
|
|
FreeStream;
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.EscapeText(const s: string): string;
|
|
begin
|
|
Result := StrFindAndReplace(s, ':', ['&:&', '<:<', '>:>',
|
|
'":"', ''':'', #13':', ' : ', #10':<br />']);
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.ExportAllPictures(Obj: TfrxView): Boolean;
|
|
begin
|
|
Result := AllPictures and ExportAsPicture(Obj)
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.ExportAsPicture(Obj: TfrxView): Boolean;
|
|
begin
|
|
DoExportAsPicture(Obj, not (Obj is TfrxPictureView), Obj.Color = clNone, False, clWhite);
|
|
CreateFrameDiv(Obj);
|
|
Result := True;
|
|
end;
|
|
|
|
class function TfrxHTMLDivExport.ExportDialogClass: TfrxBaseExportDialogClass;
|
|
begin
|
|
Result := TfrxHTMLDivExportDialog;
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.ExportGradient(Obj: TfrxView): Boolean;
|
|
var
|
|
Grad: TfrxGradientView;
|
|
begin
|
|
Result := Obj is TfrxGradientView;
|
|
if not Result then
|
|
Exit;
|
|
|
|
Grad := Obj as TfrxGradientView;
|
|
|
|
if Result then
|
|
with CreateDiv(Obj) do
|
|
with TfrxCSSStyle.Create do
|
|
begin
|
|
FillGraduienProps(This, Grad.BeginColor, Grad.EndColor, Grad.Style);
|
|
|
|
if Count > 0 then
|
|
AddCSSClass(LockStyle(This));
|
|
end;
|
|
|
|
CreateFrameDiv(Obj);
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.ExportLine(Obj: TfrxView): Boolean;
|
|
var
|
|
Line: TfrxLineView;
|
|
begin
|
|
Result := Obj is TfrxLineView;
|
|
if not Result then
|
|
Exit;
|
|
|
|
Line := Obj as TfrxLineView;
|
|
|
|
if not Line.Diagonal then
|
|
CreateFrameDiv(Line)
|
|
else if HTML5 then
|
|
with CreateDiv(Line, wbFrame) do
|
|
with TTextFragment.Create(Formatted) do
|
|
begin
|
|
Add('<svg width="100%" height="100%">');
|
|
Add(SVGLine(Formatted, True, FCSS, Line));
|
|
Add('</svg>');
|
|
Value := Text;
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.ExportMemo(Obj: TfrxView): Boolean;
|
|
|
|
function IsMemoNeedEMF(Memo: TfrxCustomMemoView): Boolean;
|
|
begin
|
|
Result := {Memo.AllowHTMLTags and IsHasHTMLTags(Memo.Memo.Text)
|
|
or }(Memo.ReducedAngle <> 0)
|
|
or (Min(Memo.GapX, Memo.GapY) <= 0);
|
|
end;
|
|
|
|
var
|
|
Memo: TfrxCustomMemoView;
|
|
ol : string;
|
|
|
|
procedure FillProps(Style: TfrxCSSStyle);
|
|
begin
|
|
with Style do
|
|
begin
|
|
Style['color'] := GetColor(Memo.Font.Color);
|
|
Style['font'] := GetFont(Memo.Font);
|
|
Style['text-decoration'] := GetTextDecoration(Memo.Font.Style);
|
|
|
|
Style['text-align'] := GetHAlign(Memo.HAlign);
|
|
Style['cursor'] := GetCursor(Memo.Cursor);
|
|
|
|
{ It's ok to ignore vaTop and vaCenter alignments.
|
|
For vaTop a <div> is created which has the top alignment
|
|
by default; for vaCenter a <table> is created which has
|
|
the middle alignment by default. }
|
|
Style['vertical-align'] := GetVAlign(Memo.VAlign);
|
|
|
|
if Memo.ParagraphGap > 0 then
|
|
Style['text-indent'] := FRLength(Memo.ParagraphGap);
|
|
|
|
if Memo.CharSpacing <> 0 then
|
|
Style['letter-spacing'] := FRLength(Memo.CharSpacing, True);
|
|
|
|
Style['line-height'] :=
|
|
IntToStr(Round(Memo.Font.Size * 96 / 72 + Memo.LineSpacing)) + 'px';
|
|
|
|
if Memo.GapY > 0.5 then
|
|
case Memo.VAlign of
|
|
vaTop:
|
|
Style['padding-top'] := Format('%dpx', [Round(Memo.GapY)]);
|
|
vaBottom:
|
|
Style['padding-bottom'] := Format('%dpx', [Round(Memo.GapY)]);
|
|
else // vaCenter:
|
|
end;
|
|
|
|
if Memo.GapX > 0.5 then
|
|
begin
|
|
if Memo.HAlign in [haLeft, haBlock] then
|
|
Style['padding-left'] := Format('%dpx', [Round(Memo.GapX)]);
|
|
if Memo.HAlign in [haRight, haBlock] then
|
|
Style['padding-right'] := Format('%dpx', [Round(Memo.GapX)]);
|
|
end;
|
|
|
|
if (Memo.Hyperlink <> nil) and (Memo.Hyperlink.Value <> '') then
|
|
Style['z-index'] := '1';
|
|
|
|
end;
|
|
end;
|
|
|
|
const
|
|
WidthFactor: array [TfrxHAlign] of Integer = (1, 1, 0, 2);
|
|
// (haLeft, haRight, haCenter, haBlock);
|
|
HeightFactor: array [TfrxVAlign] of Integer = (1, 1, 0);
|
|
// (vaTop, vaBottom, vaCenter);
|
|
|
|
var
|
|
Text, HL: string;
|
|
InnerTag: TfrxHTMLItem;
|
|
IsEmpty: Boolean;
|
|
begin
|
|
Result := (Obj is TfrxCustomMemoView)
|
|
{$IFNDEF RAD_ED}{$IFNDEF FPC}
|
|
and not IsMemoNeedEMF(TfrxCustomMemoView(Obj))
|
|
{$ENDIF}{$ENDIF}
|
|
;
|
|
if not Result then
|
|
Exit;
|
|
|
|
Memo := Obj as TfrxCustomMemoView;
|
|
CreateFillDiv(Memo);
|
|
|
|
if IsCJK(Memo.Lines.Text) then // Chinese, Japanese, Korean
|
|
Text := {$IFDEF Delphi12} Trim(Memo.WrapText(Memo.WordWrap))
|
|
{$ELSE} Trim(UTF8Encode(Memo.WrapText(Memo.WordWrap)))
|
|
{$ENDIF}
|
|
else
|
|
Text := {$IFDEF Delphi12} Trim(Memo.Lines.Text);
|
|
{$ELSE} Trim(UTF8Encode(Memo.Lines.Text));
|
|
{$ENDIF}
|
|
|
|
|
|
{ Write outline id }
|
|
ol := '';
|
|
if Outline and Assigned(Obj) then
|
|
ol := GetIdOutlineHTML(Obj.Parent.Top - Obj.Top + Obj.Height, Obj.Height, FOutlineTreeNode, 0);
|
|
|
|
IsEmpty := Memo.HideZeros and (Text = '0') or (Text = '');
|
|
if not IsEmpty then
|
|
if Memo.ReducedAngle <> 0 then
|
|
CreateDiv(Obj).RawValue := ExportViaVector(Obj)
|
|
else
|
|
with CreateDiv(Memo) do
|
|
begin
|
|
Width := Width - WidthFactor[Memo.HAlign] * Round(Memo.GapX);
|
|
Height := Height - HeightFactor[Memo.VAlign] * Round(Memo.GapY);
|
|
|
|
with TfrxCSSStyle.Create do
|
|
begin
|
|
FillProps(This);
|
|
AddCSSClass(LockStyle(This));
|
|
end;
|
|
|
|
if Memo.VAlign = vaTop then
|
|
begin
|
|
if ol<>'' then
|
|
InnerTag := This.Add('a' + ol)
|
|
else
|
|
InnerTag := This;
|
|
end
|
|
else
|
|
InnerTag := Add('table').Add('tr').Add('td' + ol);
|
|
|
|
Text := EscapeText(Text);
|
|
if Memo.AllowHTMLTags then
|
|
Text := FilterHTML(Text);
|
|
|
|
HL := DoHyperLink(Memo.Hyperlink);
|
|
if (HL <> '') then
|
|
Text := HL + Text + '</a>';
|
|
InnerTag.Value := Text;
|
|
end;
|
|
ol :='';
|
|
CreateFrameDiv(Memo);
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.ExportPicture(Obj: TfrxView): Boolean;
|
|
var
|
|
PictureView: TfrxPictureView;
|
|
Typ: TfrxFrameTypes;
|
|
begin
|
|
Result := Obj is TfrxPictureView;
|
|
if not Result then
|
|
Exit;
|
|
|
|
CreateDiv(Obj);
|
|
|
|
PictureView := (Obj as TfrxPictureView);
|
|
if not PictureView.IsEmpty then
|
|
begin
|
|
if IsPageBG(PictureView) and
|
|
(Report.PreviewPages.Page[FCurrentPage - 1] <> nil) and
|
|
not Report.PreviewPages.Page[FCurrentPage - 1].BackPictureStretched then
|
|
PictureView.Stretched := False;
|
|
|
|
if PictureView.Transparent or UnifiedPictures then
|
|
begin
|
|
Typ := Obj.Frame.Typ;
|
|
Obj.Frame.Typ := [];
|
|
DoExportAsPicture(Obj, PictureView.Transparent and (Obj.Color = clNone), PictureView.GraphicIsVector and not PictureView.GraphicIsTranslucent, (PictureView.GraphicHasAlpha or PictureView.GraphicHasMaskColor) and (Obj.Color = clNone), PictureView.GraphicTransparentColor);
|
|
Obj.Frame.Typ := Typ;
|
|
end
|
|
else
|
|
PutImg(Obj, PictureView.GetGraphic, True);
|
|
end
|
|
else if PictureView.Color <> clNone then
|
|
CreateFillDiv(Obj);
|
|
|
|
CreateFrameDiv(Obj);
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.ExportShape(Obj: TfrxView): Boolean;
|
|
var
|
|
Shape: TfrxShapeView;
|
|
begin
|
|
Result := (Obj is TfrxShapeView);
|
|
if not Result then
|
|
Exit;
|
|
Shape := Obj as TfrxShapeView;
|
|
|
|
if Shape.Shape = skRectangle then
|
|
CreateFillDiv(Obj);
|
|
|
|
with CreateDiv(Obj, wbFrame) do
|
|
if HTML5 then
|
|
with TTextFragment.Create(Formatted) do
|
|
begin
|
|
Add('<svg width="100%" height="100%">');
|
|
|
|
Add(SVGShapePath(Shape, spStroke + spHTML));
|
|
|
|
Add('</svg>');
|
|
|
|
Value := Text;
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.ExportTaggedView(Obj: TfrxView): Boolean;
|
|
begin
|
|
Result := (PictureTag <> 0) and (Obj.Tag = PictureTag) and
|
|
ExportAsPicture(Obj);
|
|
end;
|
|
|
|
{$IFNDEF FPC}
|
|
function TfrxHTMLDivExport.ExportViaEMF(Obj: TfrxView): Boolean;
|
|
|
|
procedure SetParams(EMFtoSVG: TEMFtoSVGExport);
|
|
begin
|
|
// EMFtoSVG.ShowComments := True; { TODO : Debug }
|
|
EMFtoSVG.LinearBarcode :=
|
|
(AnsiUpperCase(Obj.ClassName) = 'TFRXBARCODEVIEW');
|
|
EMFtoSVG.Formatted := Formatted;
|
|
EMFtoSVG.ForceMitterLineJoin := True;
|
|
EMFtoSVG.SetEmbedded(FCSS, Obj);
|
|
end;
|
|
|
|
var
|
|
MS1, MS2: TMemoryStream;
|
|
EMFtoSVG: TEMFtoSVGExport;
|
|
AnsiTemp: AnsiString;
|
|
begin
|
|
Result := Obj.IsEMFExportable;
|
|
if not Result then
|
|
Exit;
|
|
|
|
CreateFillDiv(Obj);
|
|
|
|
if HTML5 then
|
|
begin
|
|
MS1 := CreateMetaStream(Obj);
|
|
MS2 := nil;
|
|
try
|
|
MS2 := TMemoryStream.Create;
|
|
EMFtoSVG := TEMFtoSVGExport.Create(MS1, MS2);
|
|
try
|
|
SetParams(EMFtoSVG);
|
|
EMFtoSVG.PlayMetaFile;
|
|
finally
|
|
EMFtoSVG.Free;
|
|
end;
|
|
|
|
MS2.Position := 0;
|
|
SetLength(AnsiTemp, MS2.Size);
|
|
MS2.ReadBuffer(AnsiTemp[1], MS2.Size);
|
|
CreateDiv(Obj, wbExport).RawValue := AnsiTemp;
|
|
finally
|
|
MS1.Free;
|
|
MS2.Free;
|
|
end;
|
|
end;
|
|
|
|
CreateFrameDiv(Obj);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function TfrxHTMLDivExport.GetAnchor(var Page: string;
|
|
const Name: string): Boolean;
|
|
var
|
|
a: TfrxXMLItem;
|
|
begin
|
|
Result := Report.PreviewPages is TfrxPreviewPages;
|
|
if not Result then
|
|
Exit;
|
|
|
|
a := (Report.PreviewPages as TfrxPreviewPages).FindAnchor(Name);
|
|
if a = nil then
|
|
Exit;
|
|
|
|
Page := a.Prop['page'];
|
|
Result := Page <> '';
|
|
end;
|
|
|
|
class function TfrxHTMLDivExport.GetDescription: String;
|
|
begin
|
|
Result := GetStr('9300')
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.GetHRef(const URL: string): string;
|
|
var
|
|
Page: string;
|
|
begin
|
|
if URL = '' then
|
|
Result := ''
|
|
else
|
|
case URL[1] of
|
|
'@':
|
|
if MultiPage then
|
|
Result := Copy(URL, 2, Length(URL)) + '.html'
|
|
else
|
|
Result := '#page' + Copy(URL, 2, Length(URL));
|
|
|
|
'#':
|
|
if ExportAnchors and GetAnchor(Page, Copy(URL, 2, Length(URL))) then
|
|
try
|
|
Result := '#page' + IntToStr(StrToInt(Page) + 1)
|
|
except
|
|
Result := ''
|
|
end;
|
|
|
|
else
|
|
Result := URL
|
|
end
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.GetPageStyle: TfrxCSSStyle;
|
|
begin
|
|
if FPageStyle = nil then
|
|
begin
|
|
FPageStyle := TfrxCSSStyle.Create;
|
|
FPageStyle.Name := '.page';
|
|
end;
|
|
|
|
Result := FPageStyle;
|
|
end;
|
|
|
|
procedure TfrxHTMLDivExport.FillGraduienProps(Style: TfrxCSSStyle;
|
|
BeginColor, EndColor: TColor; GradientStyle: TfrxGradientStyle);
|
|
begin
|
|
if HTML5 then
|
|
case GradientStyle of
|
|
gsHorizontal:
|
|
Style.PrefixStyle['background'] :=
|
|
Format('linear-gradient(to right, %s, %s)',
|
|
[GetColor(BeginColor), GetColor(EndColor)]);
|
|
|
|
gsHorizCenter:
|
|
Style.PrefixStyle['background'] :=
|
|
Format('linear-gradient(to right, %s, %s, %s)',
|
|
[GetColor(BeginColor), GetColor(EndColor), GetColor(BeginColor)]);
|
|
|
|
gsVertical:
|
|
Style.PrefixStyle['background'] := Format('linear-gradient(%s, %s)',
|
|
[GetColor(BeginColor), GetColor(EndColor)]);
|
|
|
|
gsVertCenter:
|
|
Style.PrefixStyle['background'] := Format('linear-gradient(%s, %s, %s)',
|
|
[GetColor(BeginColor), GetColor(EndColor), GetColor(BeginColor)]);
|
|
|
|
gsRectangle, gsElliptic:
|
|
Style.PrefixStyle['background'] :=
|
|
Format('radial-gradient(ellipse, %s, %s)',
|
|
[GetColor(EndColor), GetColor(BeginColor)]);
|
|
end;
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.FilterHTML(const Text: string): string;
|
|
|
|
function RestoreTag(const Source, Tag: string): string;
|
|
const
|
|
LeftBracket = '<';
|
|
RightBracket = '>';
|
|
var
|
|
OutStr, SubStr, Rest: string;
|
|
|
|
function IsFound(const SearchStr, ReplaceStr: string): Boolean;
|
|
var
|
|
p: Integer;
|
|
begin
|
|
p := Pos(SearchStr, Rest);
|
|
Result := p > 0;
|
|
if Result then
|
|
begin
|
|
OutStr := OutStr + Copy(Rest, 1, p - 1) + ReplaceStr;
|
|
Delete(Rest, 1, p - 1 + Length(SearchStr));
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Rest := Source;
|
|
OutStr := '';
|
|
SubStr := LeftBracket + Tag;
|
|
while IsFound(SubStr, '<' + Tag) and IsFound(RightBracket, '>') do;
|
|
Result := OutStr + Rest;
|
|
end;
|
|
|
|
function Tag(T: string): string;
|
|
begin
|
|
Result := Format('<%s>:<%s>', [T, T]);
|
|
end;
|
|
|
|
begin
|
|
Result := StrFindAndReplace(Text, ':', [Tag('b'), Tag('/b'), Tag('strong'),
|
|
Tag('/strong'), Tag('i'), Tag('/i'), Tag('em'), Tag('/em'), Tag('u'),
|
|
Tag('/u'), Tag('s'), Tag('/s'), Tag('br'), Tag('br/'), Tag('br /'),
|
|
Tag('sub'), Tag('/sub'), Tag('sup'), Tag('/sup'), Tag('/font')]);
|
|
Result := RestoreTag(Result, 'font');
|
|
end;
|
|
|
|
procedure TfrxHTMLDivExport.FinishPage(Page: TfrxReportPage; Index: Integer);
|
|
begin
|
|
FQueue.Free;
|
|
|
|
Puts('</div>'); // <div class="page">...</div>
|
|
|
|
if FPrint then
|
|
if Server then
|
|
Puts('<script language="javascript" type="text/javascript"> print();</script>')
|
|
else
|
|
Puts('<script language="javascript" type="text/javascript"> parent.focus(); parent.print();</script>');
|
|
if MultiPage then
|
|
EndHTML;
|
|
inherited
|
|
end;
|
|
|
|
procedure TfrxHTMLDivExport.Finish;
|
|
begin
|
|
if not MultiPage then
|
|
EndHTML;
|
|
|
|
if not Assigned(Stream) and not EmbeddedCSS then
|
|
SaveCSS(GetCSSFilePath);
|
|
|
|
FCSS.Free;
|
|
FOutlineTree.Free;
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.NavPageNumber(PageNumber: Integer): string;
|
|
begin
|
|
Result := Format('page%u', [PageNumber]);
|
|
end;
|
|
|
|
procedure TfrxHTMLDivExport.PutImg(Obj: TfrxView; Pic: TGraphic;
|
|
WriteSize: Boolean);
|
|
var
|
|
HL: AnsiString;
|
|
IndexImg: Integer;
|
|
begin
|
|
if not IsCanSavePicture(Pic) then
|
|
Exit;
|
|
FQueue.Flush;
|
|
HL := AnsiString(DoHyperLink(Obj.Hyperlink));
|
|
if (HL <> '') then
|
|
PutsRaw(HL);
|
|
PutsRaw('<img style="');
|
|
|
|
PutsRaw('left:' + AnsiString(FRLength(Obj.AbsLeft)));
|
|
PutsRaw(';top:' + AnsiString(FRLength(Obj.AbsTop)));
|
|
|
|
if WriteSize then
|
|
begin
|
|
PutsRaw(';width:' + AnsiString(FRLength(Round(Obj.AbsLeft + Obj.Width) -
|
|
Round(Obj.AbsLeft))));
|
|
|
|
PutsRaw(';height:' + AnsiString(FRLength(Round(Obj.AbsTop + Obj.Height) -
|
|
Round(Obj.AbsTop))));
|
|
end;
|
|
|
|
IndexImg := FfrxPictureHashMap.FindOrAddGraphic(Pic, phmIndex);
|
|
|
|
if (EmbeddedPictures) then
|
|
begin
|
|
if (FfrxPictureHashMap.isLastNew) then
|
|
FCSS.AddName('img.frimg' + IntToStr(IndexImg))['content'] := 'url(' + SavePicture(Pic) + ')';
|
|
Puts(Format('" class="frimg%d">', [IndexImg]));
|
|
end
|
|
else
|
|
begin
|
|
Puts('" src="');
|
|
if (FfrxPictureHashMap.isLastNew) then
|
|
Puts(SavePicture(Pic, IndexImg))
|
|
else
|
|
Puts(GetPicPath(Pic, IndexImg));
|
|
|
|
Puts('">');
|
|
end;
|
|
|
|
if (HL <> '') then
|
|
PutsRaw('</a>');
|
|
end;
|
|
{
|
|
function TfrxHTMLDivExport.ShowModal: TModalResult;
|
|
|
|
procedure DisableCB(CB: TCheckBox);
|
|
begin
|
|
CB.State := cbGrayed;
|
|
CB.Enabled := False;
|
|
end;
|
|
|
|
begin
|
|
Result := mrOk;
|
|
if Assigned(Stream) then Exit;
|
|
|
|
with TfrxHTMLDivExportDialog.Create(nil) do
|
|
try
|
|
if SlaveExport then
|
|
begin
|
|
OpenAfterExport := False;
|
|
DisableCB(OpenCB);
|
|
|
|
EmbeddedCSS := True;
|
|
DisableCB(StylesCB);
|
|
|
|
EmbeddedPictures := True;
|
|
DisableCB(PicturesCB);
|
|
|
|
MultiPage := False;
|
|
DisableCB(MultipageCB);
|
|
|
|
Navigation := False;
|
|
DisableCB(NavigationCB);
|
|
|
|
PictureFormat := pfPNG;
|
|
PFormatCB.Enabled := False;
|
|
|
|
UnifiedPictures := True;
|
|
DisableCB(UnifiedPicturesCB);
|
|
end;
|
|
|
|
OpenCB.Checked := OpenAfterExport;
|
|
StylesCB.Checked := EmbeddedCSS;
|
|
PicturesCB.Checked := EmbeddedPictures;
|
|
MultipageCB.Checked := MultiPage;
|
|
NavigationCB.Checked := Navigation;
|
|
UnifiedPicturesCB.Checked := UnifiedPictures;
|
|
FormattedCB.Checked := Formatted;
|
|
PFormatCB.ItemIndex := Integer(PictureFormat);
|
|
|
|
if PageNumbers <> '' then
|
|
begin
|
|
PageNumbersE.Text := PageNumbers;
|
|
PageNumbersRB.Checked := True;
|
|
end;
|
|
|
|
if OverwritePrompt then
|
|
sd.Options := sd.Options + [ofOverwritePrompt];
|
|
sd.FileName := FileName;
|
|
sd.DefaultExt := DefaultExt;
|
|
sd.Filter := GetStr('9301');
|
|
if (FileName = '') and not SlaveExport then
|
|
sd.FileName := ChangeFileExt(
|
|
ExtractFileName(frxUnixPath2WinPath(Report.FileName)), sd.DefaultExt);
|
|
|
|
Result := ShowModal;
|
|
|
|
if Result = mrOk then
|
|
begin
|
|
OpenAfterExport := OpenCB.Checked;
|
|
EmbeddedCSS := StylesCB.Checked;
|
|
EmbeddedPictures := PicturesCB.Checked;
|
|
MultiPage := MultipageCB.Checked;
|
|
Navigation := NavigationCB.Checked;
|
|
UnifiedPictures := UnifiedPicturesCB.Checked;
|
|
Formatted := FormattedCB.Checked;
|
|
PictureFormat := TfrxPictureFormat(PFormatCB.ItemIndex);
|
|
|
|
PageNumbers := '';
|
|
CurPage := CurPageRB.Checked;
|
|
if PageNumbersRB.Checked then
|
|
PageNumbers := PageNumbersE.Text;
|
|
|
|
if not SlaveExport then
|
|
begin
|
|
if DefaultPath <> '' then
|
|
sd.InitialDir := DefaultPath;
|
|
if sd.Execute then
|
|
FileName := sd.FileName
|
|
else
|
|
Result := mrCancel;
|
|
end;
|
|
end;
|
|
finally
|
|
Free
|
|
end;
|
|
end;
|
|
}
|
|
|
|
procedure TfrxHTMLDivExport.StartAnchors;
|
|
var
|
|
AnchorRoot: TfrxXMLItem;
|
|
i: Integer;
|
|
stCurrentPage: String;
|
|
SL: TStringList;
|
|
begin
|
|
SL := TStringList.Create;
|
|
|
|
stCurrentPage := IntToStr(FCurrentPage - 1);
|
|
AnchorRoot := (Report.PreviewPages as TfrxPreviewPages).FindAnchorRoot;
|
|
if Assigned(AnchorRoot) then
|
|
for i := 0 to AnchorRoot.Count - 1 do
|
|
if (AnsiCompareText(AnchorRoot[i].Prop['page'], stCurrentPage) = 0) and
|
|
(SL.IndexOf(AnchorRoot[i].Prop['text']) = -1) then
|
|
begin
|
|
SL.Add(AnchorRoot[i].Prop['text']);
|
|
Puts('<div id="%s" style="left:0;top:%spx;width:0;height:0;"></div>',
|
|
[TfrxHTMLItem.EscapeAttribute(AnchorRoot[i].Prop['text']),
|
|
AnchorRoot[i].Prop['top']]);
|
|
end;
|
|
|
|
SL.Free;
|
|
end;
|
|
|
|
procedure TfrxHTMLDivExport.StartHTML;
|
|
var
|
|
tit, stoolbar: String;
|
|
ol: String;
|
|
begin
|
|
if not FUseTemplates then
|
|
begin
|
|
if HTML5 then
|
|
Puts('<!doctype html>')
|
|
else
|
|
Puts('<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" ' +
|
|
'"http://www.w3.org/TR/html4/strict.dtd">');
|
|
|
|
Puts('<html>');
|
|
Puts('<head>');
|
|
Puts('<title>%s</title>', [Title]);
|
|
Puts('<meta http-equiv="Content-Type" content="text/html; charset=utf-8">');
|
|
|
|
if not EmbeddedCSS then
|
|
Puts('<link rel="stylesheet" href="%s">', [GetCSSFileName]);
|
|
|
|
Puts('</head>');
|
|
Puts('<body>');
|
|
|
|
if Outline then
|
|
begin
|
|
ol := '<ul class="outlineCSS">';
|
|
if FOutlineTree.CountTree > 0 then
|
|
begin
|
|
{ Write outline nodes }
|
|
WriteHTMLOutline(TfrxHTMLOutlineNode(FOutlineTree.First),ol);
|
|
ol := ol + '</ul>';
|
|
end;
|
|
Puts('<div class = "blockOutline">');
|
|
Puts(ol);
|
|
Puts('</div><div style="clear: left;"></div>');
|
|
Puts('<div class = "blockReport">');
|
|
if FOutlineTree.First <> nil then
|
|
FOutlineTreeNode := TfrxHTMLOutlineNode(FOutlineTree.First);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if Assigned(FGetMainTemplate) then
|
|
begin
|
|
stoolbar := '';
|
|
tit := ExtractFileName(Report.FileName);
|
|
delete(tit, length(tit)-3, 4);
|
|
FGetMainTemplate(String(UTF8Encode(tit)), // title
|
|
ReverseSlash(Self.FileName), // frame folder
|
|
MultiPage, // multipage
|
|
Navigation,
|
|
stoolbar);
|
|
{$IFDEF Delphi12}
|
|
//TempString := UTF8Encode(st);
|
|
//Exp.Write(TempString[1], Length(TempString));
|
|
Puts(stoolbar);
|
|
{$ELSE}
|
|
Puts(stoolbar);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxHTMLDivExport.StartNavigator;
|
|
begin
|
|
if Formatted then
|
|
Puts('<!-- navigation -->');
|
|
|
|
Puts('<div class="nav" style="position:relative">');
|
|
|
|
if FCurrentPage > 1 then
|
|
begin
|
|
Puts('<a href="%u%s" title="Goto page %u">|◄ First</a>',
|
|
[1, DefaultExt, 1]);
|
|
Puts('<a href="%u%s" title="Goto page %d">◄ Back</a>',
|
|
[FCurrentPage - 1, DefaultExt, FCurrentPage - 1]);
|
|
end
|
|
else
|
|
begin
|
|
Puts('<a href="#">|| First</a>');
|
|
Puts('<a href="#">| Back</a>');
|
|
end;
|
|
|
|
if FCurrentPage < Report.PreviewPages.Count then
|
|
begin
|
|
Puts('<a href="%d%s" title="Goto page %d">Next ►</a>',
|
|
[FCurrentPage + 1, DefaultExt, FCurrentPage + 1]);
|
|
Puts('<a href="%u%s" title="Goto page %u">Last ►|</a>',
|
|
[Report.PreviewPages.Count, DefaultExt, Report.PreviewPages.Count]);
|
|
end
|
|
else
|
|
begin
|
|
Puts('<a href="#">Next |</a>');
|
|
Puts('<a href="#">Last ||</a>');
|
|
end;
|
|
|
|
Puts('</div>');
|
|
end;
|
|
|
|
function TfrxHTMLDivExport.Start: Boolean;
|
|
var
|
|
OutlineObjId: Integer;
|
|
begin
|
|
Result := inherited Start;
|
|
FOutlineTree := TfrxHTMLOutlineNode.Create;
|
|
if Outline then
|
|
begin
|
|
OutlineObjId := 0;
|
|
FPreviewOutline := Report.PreviewPages.Outline;
|
|
FPreviewOutline.LevelRoot;
|
|
PrepareHTMLOutline(FPreviewOutline, FOutlineTree, OutlineObjId);
|
|
end;
|
|
|
|
if Server then
|
|
begin
|
|
if MultiPage then
|
|
StartHTML;
|
|
if Formatted then
|
|
Puts('<!-- page #0 -->');
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxHTMLDivExport.StartPage(Page: TfrxReportPage; Index: Integer);
|
|
var
|
|
stoolbar: String;
|
|
begin
|
|
inherited;
|
|
if Server then
|
|
begin
|
|
FreeStream();
|
|
FFilterStream := IOTransport.GetStream(ExtractFilePath(FileName) + 'index.' + IntToStr(Index+1) + '.html');
|
|
FCurrentFile := TCachedStream.Create(FFilterStream, False);
|
|
FQueue := TfrxHTMLItemQueue.Create(FCurrentFile, Formatted);
|
|
if Assigned(FGetToolbarTemplate) then
|
|
begin
|
|
stoolbar := '';
|
|
FGetToolbarTemplate(FCurrentPage, Report.PreviewPages.Count, MultiPage, Navigation, stoolbar);
|
|
Puts(stoolbar);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
FQueue := TfrxHTMLItemQueue.Create(FCurrentFile, Formatted);
|
|
|
|
if MultiPage or (FCurrentPage = 1) then
|
|
StartHTML;
|
|
|
|
if MultiPage and Navigation then
|
|
StartNavigator;
|
|
|
|
if Formatted then
|
|
Puts('<!-- page #%d -->', [Index]);
|
|
|
|
end;
|
|
|
|
Puts('<div id="page%d" class="page" style="position:relative;width:%s;height:%s">',
|
|
[Index + 1, FRLength(Page.Width), FRLength(Page.Height)]);
|
|
|
|
StartAnchors;
|
|
end;
|
|
|
|
{ TfrxHTMLItem }
|
|
|
|
function TfrxHTMLItem.Add(const Tag: string): TfrxHTMLItem;
|
|
begin
|
|
Result := TfrxHTMLItem.Create(Tag);
|
|
FChildren.Add(Result);
|
|
end;
|
|
|
|
function TfrxHTMLItem.Add(Item: TfrxHTMLItem): TfrxHTMLItem;
|
|
begin
|
|
FChildren.Add(Item);
|
|
Result := Item;
|
|
end;
|
|
|
|
procedure TfrxHTMLItem.AddCSSClass(const s: string);
|
|
begin
|
|
if FClass = '' then
|
|
FClass := s
|
|
else
|
|
FClass := FClass + ' ' + s
|
|
end;
|
|
|
|
function TfrxHTMLItem.AddRotated(const Tag: string; ARotation: Integer)
|
|
: TfrxHTMLItem;
|
|
begin
|
|
Result := TfrxHTMLItem.Create(Tag);
|
|
Result.FRotation := ARotation;
|
|
FChildren.Add(Result);
|
|
end;
|
|
|
|
function TfrxHTMLItem.AddTransformed(const Tag: string;
|
|
ATransformMatrix: array of Extended): TfrxHTMLItem;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := TfrxHTMLItem.Create(Tag);
|
|
Result.FIsTransformMatrix := True;
|
|
SetLength(Result.FTM, Length(ATransformMatrix));
|
|
for i := 0 to High(Result.FTM) do
|
|
Result.FTM[i] := ATransformMatrix[i];
|
|
FChildren.Add(Result);
|
|
end;
|
|
|
|
constructor TfrxHTMLItem.Create(const Name: string);
|
|
begin
|
|
FName := Name;
|
|
FKeys := TStringList.Create;
|
|
FValues := TStringList.Create;
|
|
FChildren := TObjList.Create;
|
|
FAllowNegativeLeft := False;
|
|
FIsTransformMatrix := False;
|
|
end;
|
|
|
|
destructor TfrxHTMLItem.Destroy;
|
|
begin
|
|
FKeys.Free;
|
|
FValues.Free;
|
|
FChildren.Free;
|
|
FStyle.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TfrxHTMLItem.DoPositive;
|
|
begin
|
|
if Width < 0 then
|
|
Left := Left + Width;
|
|
Width := Abs(Width);
|
|
if Height < 0 then
|
|
Top := Top + Height;
|
|
Height := Abs(Height);
|
|
end;
|
|
|
|
class function TfrxHTMLItem.EscapeAttribute(const s: string): string;
|
|
begin
|
|
Result := StrFindAndReplace(s, ':', ['&:&', '<:<', '>:>',
|
|
'":"', ''':'', #13, ' : ']);
|
|
end;
|
|
|
|
procedure TfrxHTMLItem.Gaude(Obj: TfrxView);
|
|
begin
|
|
GaudeFrame(Obj);
|
|
if ftLeft in Obj.Frame.Typ then
|
|
Left := Left + Obj.Frame.LeftLine.Width;
|
|
if ftTop in Obj.Frame.Typ then
|
|
Top := Top + Obj.Frame.TopLine.Width;
|
|
end;
|
|
|
|
procedure TfrxHTMLItem.GaudeFrame(Obj: TfrxView);
|
|
var
|
|
BGauge: TfrxBoundsGauge;
|
|
begin
|
|
BGauge := TfrxBoundsGauge.Create;
|
|
BGauge.Obj := Obj;
|
|
|
|
Left := BGauge.Bounds.Left;
|
|
Top := BGauge.Bounds.Top;
|
|
Width := BGauge.InnerWidth;
|
|
Height := BGauge.InnerHeight;
|
|
|
|
BGauge.Free;
|
|
end;
|
|
|
|
function TfrxHTMLItem.GetProp(Index: string): string;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := '';
|
|
i := FKeys.IndexOf(Index);
|
|
if i <> -1 then
|
|
Result := FValues[i];
|
|
end;
|
|
|
|
function TfrxHTMLItem.GetStyle: TfrxCSSStyle;
|
|
begin
|
|
if FStyle = nil then
|
|
FStyle := TfrxCSSStyle.Create;
|
|
|
|
Result := FStyle;
|
|
end;
|
|
|
|
procedure TfrxHTMLItem.Save(Stream: TStream; Formatted: Boolean);
|
|
|
|
procedure PutsRaw(const s: AnsiString);
|
|
begin
|
|
Stream.Write(s[1], Length(s))
|
|
end;
|
|
|
|
procedure Puts(const s: string; IsNeedEndLine: Boolean = False);
|
|
begin
|
|
if s <> '' then
|
|
begin
|
|
{$IFDEF Delphi12}
|
|
PutsRaw(AnsiString(UTF8Encode(s)));
|
|
{$ELSE}
|
|
PutsRaw(AnsiString(s));
|
|
{$ENDIF}
|
|
if IsNeedEndLine then
|
|
PutsRaw(AnsiString(#13#10))
|
|
end;
|
|
end;
|
|
|
|
function DontNeedEndLine(const T: string): Boolean;
|
|
begin
|
|
Result := (T = 'a') or (T = 'tr') or (T = 'td')
|
|
end;
|
|
|
|
function IsShortTag(const T: string): Boolean;
|
|
begin
|
|
Result := (T = 'tr') or (T = 'td') or (T = 'p') or (T = 'img')
|
|
end;
|
|
|
|
procedure WriteDim;
|
|
begin
|
|
if FLeftSet then
|
|
Style['left'] := FRLength(Left, AllowNegativeLeft);
|
|
|
|
if FTopSet then
|
|
Style['top'] := FRLength(Top);
|
|
|
|
if FWidthSet then
|
|
Style['width'] := FRLength(Round(Left + Width) - Round(Left));
|
|
|
|
if FHeightSet then
|
|
Style['height'] := FRLength(Round(Top + Height) - Round(Top));
|
|
|
|
if FRotation <> 0 then
|
|
Style['transform'] := Format('rotate(%ddeg)', [FRotation]);
|
|
|
|
if FIsTransformMatrix then
|
|
Style['transform'] := Format('matrix(%s, %s, %s, %s, %s, %s)',
|
|
[frFloat2Str(FTM[0], 3), frFloat2Str(FTM[1], 3), frFloat2Str(FTM[2], 3),
|
|
frFloat2Str(FTM[3], 3), frFloat2Str(FTM[4], 0), frFloat2Str(FTM[5], 0)]);
|
|
|
|
if FStyle <> nil then
|
|
Puts(' style="' + FStyle.Text + '"');
|
|
end;
|
|
|
|
var
|
|
ShortTag: Boolean;
|
|
i: Integer;
|
|
begin
|
|
ShortTag := IsShortTag(FName);
|
|
|
|
Puts('<' + FName);
|
|
|
|
for i := 0 to FKeys.Count - 1 do
|
|
Puts(' ' + FKeys[i] + '="' + string(EscapeAttribute(FValues[i])) + '"');
|
|
|
|
if FClass <> '' then
|
|
Puts(' class="' + FClass + '"');
|
|
|
|
WriteDim;
|
|
|
|
Puts('>', Formatted and not DontNeedEndLine(FName));
|
|
|
|
for i := 0 to FChildren.Count - 1 do
|
|
TfrxHTMLItem(FChildren[i]).Save(Stream, Formatted);
|
|
|
|
if FValue <> '' then
|
|
Puts(FValue, Formatted);
|
|
|
|
if FRawValue <> '' then
|
|
PutsRaw(FRawValue);
|
|
|
|
if not ShortTag then
|
|
Puts('</' + FName + '>', Formatted);
|
|
end;
|
|
|
|
procedure TfrxHTMLItem.SetHeight(a: Extended);
|
|
begin
|
|
FHeightSet := True;
|
|
FHeight := a;
|
|
end;
|
|
|
|
procedure TfrxHTMLItem.SetLeft(a: Extended);
|
|
begin
|
|
FLeftSet := True;
|
|
FLeft := a;
|
|
end;
|
|
|
|
procedure TfrxHTMLItem.SetProp(Index: string; const Value: string);
|
|
begin
|
|
FKeys.Add(Index);
|
|
FValues.Add(Value);
|
|
end;
|
|
|
|
procedure TfrxHTMLItem.SetTop(a: Extended);
|
|
begin
|
|
FTopSet := True;
|
|
FTop := a;
|
|
end;
|
|
|
|
procedure TfrxHTMLItem.SetWidth(a: Extended);
|
|
begin
|
|
FWidthSet := True;
|
|
FWidth := a;
|
|
end;
|
|
|
|
function TfrxHTMLItem.This: TfrxHTMLItem;
|
|
begin
|
|
Result := Self
|
|
end;
|
|
|
|
procedure TfrxHTMLItem.WidenBy(Size: Extended);
|
|
begin
|
|
Left := Left - Size / 2;
|
|
Top := Top - Size / 2;
|
|
Width := Width + Size;
|
|
Height := Height + Size;
|
|
end;
|
|
|
|
{ TfrxHTMLItemQueue }
|
|
|
|
constructor TfrxHTMLItemQueue.Create(Stream: TStream; Formatted: Boolean);
|
|
begin
|
|
FStream := Stream;
|
|
FFormatted := Formatted;
|
|
SetQueueLength(10);
|
|
end;
|
|
|
|
destructor TfrxHTMLItemQueue.Destroy;
|
|
begin
|
|
Flush;
|
|
inherited
|
|
end;
|
|
|
|
procedure TfrxHTMLItemQueue.Flush;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to FUsed - 1 do
|
|
with FQueue[i] do
|
|
begin
|
|
Save(FStream, FFormatted);
|
|
Free;
|
|
end;
|
|
|
|
FUsed := 0
|
|
end;
|
|
|
|
procedure TfrxHTMLItemQueue.Push(Item: TfrxHTMLItem);
|
|
begin
|
|
if FUsed = Length(FQueue) then
|
|
Flush;
|
|
|
|
FQueue[FUsed] := Item;
|
|
Inc(FUsed);
|
|
end;
|
|
|
|
procedure TfrxHTMLItemQueue.SetQueueLength(n: Integer);
|
|
begin
|
|
if FUsed > 0 then
|
|
raise Exception.Create('Cannot resize a nonempty queue');
|
|
|
|
SetLength(FQueue, n)
|
|
end;
|
|
|
|
{ TfrxBoundsGauge }
|
|
|
|
procedure TfrxBoundsGauge.AddBounds(r: TRect);
|
|
begin
|
|
if not FBoundsSet then
|
|
FBounds := r
|
|
else
|
|
with FBounds do
|
|
begin
|
|
Left := Min(Left, r.Left);
|
|
Right := Max(Right, r.Right);
|
|
Top := Min(Top, r.Top);
|
|
Bottom := Max(Bottom, r.Bottom);
|
|
end;
|
|
|
|
FBoundsSet := True;
|
|
end;
|
|
|
|
procedure TfrxBoundsGauge.BeginDraw;
|
|
begin
|
|
with Obj do
|
|
begin
|
|
FX := Round(AbsLeft);
|
|
FY := Round(AbsTop);
|
|
FX1 := Round(AbsLeft + Width) - Round(ShadowSize);
|
|
FY1 := Round(AbsTop + Height) - Round(ShadowSize);
|
|
|
|
FDX := FX1 - FX;
|
|
FDY := FY1 - FY;
|
|
|
|
FFrameWidth := Round(Frame.Width);
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxBoundsGauge.DrawBackground;
|
|
begin
|
|
with FObj do
|
|
begin
|
|
AddBounds(Rect(FX, FY, FX1 - 1, FY1 - 1));
|
|
|
|
if BrushStyle <> bsSolid then
|
|
AddBounds(Rect(FX, FY, FX1, FY1));
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxBoundsGauge.DrawFrame;
|
|
var
|
|
d, PenWidth: Integer;
|
|
|
|
procedure Line(x, y, x1, y1: Integer; Line: TfrxFrameLine; Typ: TfrxFrameType;
|
|
gap1, gap2: Boolean);
|
|
var
|
|
g1, g2, fw: Integer;
|
|
|
|
begin
|
|
fw := Round(Line.Width);
|
|
|
|
if Line.Style in [fsSolid, fsDouble] then
|
|
begin
|
|
if gap1 then
|
|
g1 := 0
|
|
else
|
|
g1 := 1;
|
|
if gap2 then
|
|
g2 := 0
|
|
else
|
|
g2 := 1;
|
|
|
|
if Typ in [ftTop, ftBottom] then
|
|
begin
|
|
x := x + (fw * g1 div 2);
|
|
x1 := x1 - (fw * g2 div 2);
|
|
end
|
|
else
|
|
begin
|
|
y := y + (fw * g1 div 2);
|
|
y1 := y1 - (fw * g2 div 2);
|
|
end;
|
|
end;
|
|
|
|
DrawLine(x, y, x1, y1, fw, Typ);
|
|
end;
|
|
|
|
procedure SetPen(Line: TfrxFrameLine);
|
|
begin
|
|
if Line.Style in [fsSolid, fsDouble] then
|
|
PenWidth := Round(Line.Width)
|
|
else
|
|
PenWidth := 1;
|
|
end;
|
|
|
|
begin
|
|
with Obj do
|
|
if (Frame.Typ <> []) and (Frame.Color <> clNone) and (Frame.Width <> 0) then
|
|
begin
|
|
if ftLeft in Frame.Typ then
|
|
begin
|
|
SetPen(Frame.LeftLine);
|
|
|
|
if (PenWidth = 2) and (Frame.Style <> fsSolid) then
|
|
d := 1
|
|
else
|
|
d := 0;
|
|
|
|
Line(FX, FY - d, FX, FY1, Frame.LeftLine, ftLeft, ftTop in Frame.Typ,
|
|
ftBottom in Frame.Typ);
|
|
end;
|
|
|
|
if ftRight in Frame.Typ then
|
|
begin
|
|
SetPen(Frame.RightLine);
|
|
|
|
Line(FX1, FY, FX1, FY1, Frame.RightLine, ftRight, ftTop in Frame.Typ,
|
|
ftBottom in Frame.Typ);
|
|
end;
|
|
|
|
if ftTop in Frame.Typ then
|
|
begin
|
|
SetPen(Frame.TopLine);
|
|
|
|
Line(FX, FY, FX1, FY, Frame.TopLine, ftTop, ftLeft in Frame.Typ,
|
|
ftRight in Frame.Typ);
|
|
end;
|
|
|
|
if ftBottom in Frame.Typ then
|
|
begin
|
|
SetPen(Frame.BottomLine);
|
|
|
|
if (PenWidth = 1) and (Frame.Style <> fsSolid) then
|
|
d := 1
|
|
else
|
|
d := 0;
|
|
|
|
Line(FX, FY1, FX1 + d, FY1, Frame.BottomLine, ftBottom,
|
|
ftLeft in Frame.Typ, ftRight in Frame.Typ);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxBoundsGauge.DrawLine(x1, y1, x2, y2, w: Integer;
|
|
Side: TfrxFrameType);
|
|
var
|
|
LineBounds: TRect;
|
|
begin
|
|
with LineBounds do
|
|
begin
|
|
Left := x1 - w div 2;
|
|
Top := y1 - w div 2;
|
|
Right := x2 + w - w div 2 - 1;
|
|
Bottom := y2 + w - w div 2 - 1;
|
|
end;
|
|
|
|
AddBounds(LineBounds);
|
|
|
|
with FBorders do
|
|
case Side of
|
|
ftLeft:
|
|
Left := w;
|
|
ftRight:
|
|
Right := w;
|
|
ftTop:
|
|
Top := w;
|
|
ftBottom:
|
|
Bottom := w;
|
|
end;
|
|
end;
|
|
|
|
function TfrxBoundsGauge.GetInnerHeight: Integer;
|
|
begin
|
|
if FBoundsSet then
|
|
Result := FBounds.Bottom - FBounds.Top + 1
|
|
else
|
|
Result := 0;
|
|
|
|
Dec(Result, FBorders.Bottom + FBorders.Top);
|
|
end;
|
|
|
|
function TfrxBoundsGauge.GetInnerWidth: Integer;
|
|
begin
|
|
if FBoundsSet then
|
|
Result := FBounds.Right - FBounds.Left + 1
|
|
else
|
|
Result := 0;
|
|
|
|
Dec(Result, FBorders.Right + FBorders.Left);
|
|
end;
|
|
|
|
procedure TfrxBoundsGauge.SetObj(Obj: TfrxView);
|
|
begin
|
|
FObj := Obj;
|
|
FBoundsSet := False;
|
|
FBounds := Rect(0, 0, 0, 0);
|
|
FBorders := Rect(0, 0, 0, 0);
|
|
|
|
{ Simulates TfrxView.Draw, but computes bounds and borders
|
|
instead of actual drawing. }
|
|
BeginDraw;
|
|
DrawBackground;
|
|
DrawFrame;
|
|
end;
|
|
|
|
{ TfrxHTML5DivExport }
|
|
|
|
constructor TfrxHTML5DivExport.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
|
|
HTML5 := True; // use HTML5 features
|
|
ExportAnchors := True; // export page anchors
|
|
Navigation := True;
|
|
|
|
{ Make a rounded border around each page }
|
|
|
|
PageStyle['border'] := '1mm solid orange'; // CSS1 style
|
|
PageStyle['margin'] := '5mm'; // cSS1 style
|
|
PageStyle.PrefixStyle['box-shadow'] := '3mm 3mm 3mm gray'; // CSS3 style
|
|
PageStyle.PrefixStyle['border-radius'] := '2mm'; // CSS3 style
|
|
end;
|
|
|
|
class function TfrxHTML5DivExport.GetDescription: String;
|
|
begin
|
|
Result := GetStr('9303')
|
|
end;
|
|
|
|
{ TfrxHTML4DivExport }
|
|
|
|
constructor TfrxHTML4DivExport.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
|
|
ExportAnchors := True; // export page anchors
|
|
EmbeddedPictures := False; // embed pictures into HTML
|
|
EmbeddedCSS := False; // embed CSS into HTML
|
|
end;
|
|
|
|
class function TfrxHTML4DivExport.GetDescription: String;
|
|
begin
|
|
Result := GetStr('9304')
|
|
end;
|
|
|
|
end.
|