mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-06 06:18:12 +02:00
468 lines
12 KiB
ObjectPascal
468 lines
12 KiB
ObjectPascal
|
|
{*****************************************}
|
|
{ }
|
|
{ FastReport v2.3 }
|
|
{ HTM export filter }
|
|
{ }
|
|
{ Copyright (c) 1998-99 by Tzyganenko A. }
|
|
{ }
|
|
{*****************************************}
|
|
|
|
unit LR_E_HTM;
|
|
|
|
interface
|
|
|
|
{$I lr_vers.inc}
|
|
{$COPERATORS on}
|
|
|
|
uses
|
|
Classes, SysUtils, LResources,
|
|
Graphics, GraphType, Controls, Forms, Dialogs, LR_E_TXT,
|
|
LCLType, LCLIntf, LR_Class;
|
|
|
|
type
|
|
|
|
{ TStyleDesc }
|
|
TStyleDesc = record
|
|
styleID: AnsiString;
|
|
styleInfo: AnsiString;
|
|
end;
|
|
|
|
{ TfrHTMExport }
|
|
|
|
TfrHTMExport = class(TComponent)
|
|
public
|
|
constructor Create(aOwner: TComponent); override;
|
|
end;
|
|
|
|
{ TfrHTMExportFilter }
|
|
|
|
TfrHTMExportFilter = class(TfrTextExportFilter)
|
|
private
|
|
cssStyles: array of TStyleDesc;
|
|
FUseCSS: boolean;
|
|
styleStartLine: integer;
|
|
outputLines: TStringList;
|
|
FLastField: PfrTextRec;
|
|
function AddStyle(p: PfrTextRec): Integer;
|
|
function ColorToHex(c: TColor): AnsiString;
|
|
function StyleIndex(p: PfrTextRec; AddIfNotFound: boolean = true): Integer;
|
|
function TextStyleID(p: PfrTextRec): AnsiString;
|
|
protected
|
|
procedure AppendLine(const s: AnsiString);
|
|
procedure InsertLine(const s: AnsiString; position: Integer);
|
|
function GetviewText({%H-}View:TfrView): string; override;
|
|
procedure CalcXCoords(var x,w: integer); override;
|
|
public
|
|
constructor Create(AStream: TStream); override;
|
|
destructor Destroy; override;
|
|
procedure OnData(x, y: Integer; View: TfrView); override;
|
|
procedure OnText({%H-}X, {%H-}Y: Integer; const Text: String; {%H-}View: TfrView); override;
|
|
procedure OnEndPage; override;
|
|
procedure OnEndDoc; override;
|
|
|
|
property UseCSS: boolean read FUseCSS write FUseCSS;
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
uses LR_Const;
|
|
|
|
|
|
constructor TfrHTMExportFilter.Create(AStream: TStream);
|
|
var
|
|
s: String;
|
|
begin
|
|
inherited Create(AStream);
|
|
outputLines:= TStringList.Create;
|
|
SetLength(cssStyles, 0);
|
|
|
|
s:= '<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">' + LineEnding;
|
|
AppendLine(s);
|
|
s:= '<html>' + LineEnding +
|
|
'<head>' + LineEnding +
|
|
'<meta name="generator" content="LazReport html exporter">' + LineEnding +
|
|
'<meta http-equiv="content-type" content="text/html; charset=UTF-8">' + LineEnding +
|
|
'<title>LazReport Exported Report</title>' + LineEnding; // TODO: improve
|
|
AppendLine(s);
|
|
s:= '<!-- CSS section start -->' + LineEnding +
|
|
'<style type="text/css">' + LineEnding;
|
|
AppendLine(s);
|
|
styleStartLine:= outputLines.Count;
|
|
|
|
s:= '</style>' + LineEnding +
|
|
'<!-- CSS section end -->' + LineEnding +
|
|
'</head>' + LineEnding + LineEnding;
|
|
AppendLine(s);
|
|
s:= '<body bgColor="#FFFFFF">' + LineEnding;
|
|
AppendLine(s);
|
|
|
|
FUseCSS := true;
|
|
end;
|
|
|
|
destructor TfrHTMExportFilter.Destroy;
|
|
begin
|
|
SetLength(cssStyles, 0);
|
|
outputLines.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
|
|
{%REGION 'procedure TfrHTMExportFilter.OnEndPage' }
|
|
procedure TfrHTMExportFilter.OnEndPage;
|
|
var
|
|
i, j, n, cw, xp, xp2: integer;
|
|
p: PfrTextRec;
|
|
s, s1, s2, s3, s4, sp, sAlign, sStyle, sEmpCells, sColSpan: AnsiString;
|
|
xPos: TStringList;
|
|
|
|
function GetHTMLFontSize(Size: integer): string;
|
|
begin
|
|
case Size of
|
|
6, 7: Result := '1';
|
|
8, 9: Result := '2';
|
|
14..17: Result := '4';
|
|
18..23: Result := '5';
|
|
24..35: Result := '6'
|
|
else
|
|
Result := '7';
|
|
end;
|
|
end;
|
|
|
|
function GetHTMLFontStyle(Style: integer): string;
|
|
begin
|
|
Result := '';
|
|
if (Style and $1) <> 0 then
|
|
Result := '<i>';
|
|
if (Style and $2) <> 0 then
|
|
Result := Result + '<b>';
|
|
if (Style and $4) <> 0 then
|
|
Result := Result + '<u>';
|
|
end;
|
|
|
|
function GetEndHTMLFontStyle(Style: Integer): String;
|
|
begin
|
|
Result := '';
|
|
if (Style and $4) <> 0 then
|
|
Result := '</u>';
|
|
if (Style and $2) <> 0 then
|
|
Result := Result + '</b>';
|
|
if (Style and $1) <> 0 then
|
|
Result := Result + '</i>';
|
|
end;
|
|
|
|
function FormatCellText(const sIn: AnsiString): AnsiString;
|
|
var
|
|
c, m: Integer;
|
|
begin
|
|
Result:= '';
|
|
c:=1;
|
|
while (c<=Length(sIn)) and (sIn[c]=' ') do
|
|
inc(c);
|
|
dec(c);
|
|
for m:=1 to c do
|
|
Result:= Result + ' ';
|
|
Result:= Result + Copy(sIn, c+1, Length(sIn)-c);
|
|
end;
|
|
|
|
begin
|
|
|
|
n := Lines.Count - 1;
|
|
while n >= 0 do
|
|
begin
|
|
if Lines[n] <> nil then
|
|
break;
|
|
Dec(n);
|
|
end;
|
|
|
|
xPos:= TStringList.Create;
|
|
xPos.Sorted:= true;
|
|
for i := 0 to n do
|
|
begin
|
|
p := PfrTextRec(Lines[i]);
|
|
while p <> nil do
|
|
begin
|
|
s:= Format('%.5d', [p^.X]);
|
|
if xPos.IndexOf(s) < 0 then
|
|
xPos.Add(s);
|
|
s:= Format('%.5d', [p^.X + p^.W]);
|
|
if xPos.IndexOf(s) < 0 then
|
|
xPos.Add(s);
|
|
p:= p^.Next;
|
|
end;
|
|
end;
|
|
|
|
s := '<table align="center" width="90%" cellspacing="0" style="border-collapse: collapse;">'+LineEnding;
|
|
s += '<tr>';
|
|
for j:=1 to xPos.Count do
|
|
s += '<td></td>';
|
|
s += '</tr>'+LineEnding;
|
|
AppendLine(s);
|
|
|
|
for i := 0 to n do
|
|
begin
|
|
|
|
p := PfrTextRec(Lines[i]);
|
|
s := '<tr>';
|
|
cw:= 0;
|
|
while p <> nil do
|
|
begin
|
|
|
|
s1:= '';
|
|
s2:= '';
|
|
s3:= '';
|
|
s4:= '';
|
|
sEmpCells:= '';
|
|
sColSpan:= '';
|
|
sAlign:= '';
|
|
sStyle:= '';
|
|
|
|
if (p^.FontColor = clWhite) or (p^.FontColor = clNone) then
|
|
p^.FontColor := clBlack;
|
|
|
|
if FUseCSS then
|
|
begin
|
|
sStyle:= Format(' class="fs%d"', [StyleIndex(p, true)]);
|
|
end
|
|
else
|
|
begin
|
|
if p^.FontColor <> clBlack then
|
|
s1:= ' Color="' + ColorToHex(p^.FontColor) + '"';
|
|
// most reports is done with font size = 10..13 - treat it as default font
|
|
if not (p^.FontSize in [10..13]) then
|
|
s1 := s1 + ' Size=' + GetHTMLFontSize(p^.FontSize);
|
|
if p^.FontStyle <> 0 then
|
|
begin
|
|
s2 := GetHTMLFontStyle(p^.FontStyle);
|
|
s3 := GetEndHTMLFontStyle(p^.FontStyle);
|
|
end;
|
|
if s1 <> '' then
|
|
begin
|
|
s1 := '<Font' + s1 + '>';
|
|
s4 := '</Font>';
|
|
end;
|
|
end;
|
|
|
|
case p^.Alignment of
|
|
taRightJustify: sAlign:= ' align="right"';
|
|
taCenter: sAlign:= ' align="center"';
|
|
end;
|
|
|
|
sp:= Format('%.5d', [p^.X]);
|
|
xp:= xPos.IndexOf(sp);
|
|
sp:= Format('%.5d', [p^.X + p^.W]);
|
|
xp2 := 0;
|
|
xPos.Find(sp, xp2);
|
|
if Assigned(p^.Next) then
|
|
begin
|
|
sp:= Format('%.5d', [p^.Next^.X]);
|
|
if xPos.IndexOf(sp)<xp2 then
|
|
xp2:= xPos.IndexOf(sp);
|
|
end;
|
|
if xp>cw then
|
|
if (xp-cw)>1 then
|
|
sEmpCells:= Format('<td colspan=%d></td>', [xp - cw])
|
|
else
|
|
sEmpCells:= '<td></td>';
|
|
|
|
if (xp2-xp)>1 then
|
|
sColSpan:= Format(' colspan=%d', [xp2 - xp]);
|
|
cw:= xp2;
|
|
|
|
s := Format('%s%s<td%s%s%s>%s%s%s%s%s</td>', [s, sEmpCells, sAlign, sStyle,
|
|
sColSpan, s1, s2, FormatCellText(p^.Text), s3, s4]);
|
|
p := p^.Next;
|
|
end;
|
|
|
|
if s = '<tr>' then
|
|
s += '<td></td>';
|
|
|
|
s += '</tr>';
|
|
AppendLine(s + LineEnding);
|
|
|
|
end;
|
|
|
|
xPos.Free;
|
|
|
|
s := '</table>' + LineEnding;
|
|
AppendLine(s);
|
|
end;
|
|
{%ENDREGION }
|
|
|
|
|
|
function TfrHTMExportFilter.TextStyleID(p: PfrTextRec): AnsiString;
|
|
var
|
|
x: Integer;
|
|
begin
|
|
Result:= '(none)';
|
|
if p=nil then
|
|
exit;
|
|
Result := p^.FontName;
|
|
Result += LowerCase(IntToHex(p^.FontSize, 2) + IntToHex(p^.FontStyle, 2) +
|
|
IntToHex(p^.FontColor, 8) + IntToHex(p^.FillColor, 8) +
|
|
IntToHex(Integer(p^.Borders), 2) + IntToHex(Ord(p^.Alignment), 2));
|
|
for x:=1 to Length(Result) do
|
|
if not (Result[x] in ['$', '%', '&', '0'..'9', '@'..'z']) then
|
|
Result[x]:= '_';
|
|
end;
|
|
|
|
|
|
function TfrHTMExportFilter.StyleIndex(p: PfrTextRec; AddIfNotFound: boolean): integer;
|
|
var
|
|
s: string;
|
|
x: integer;
|
|
begin
|
|
Result:= -1;
|
|
s:= TextStyleID(p);
|
|
for x:=0 to High(cssStyles) do
|
|
if cssStyles[x].styleID = s then
|
|
begin
|
|
Result:= x;
|
|
break;
|
|
end;
|
|
if (Result<0) and AddIfNotFound then
|
|
Result:= AddStyle(p);
|
|
end;
|
|
|
|
|
|
function TfrHTMExportFilter.AddStyle(p: PfrTextRec): Integer;
|
|
var
|
|
s: string;
|
|
begin
|
|
Result:= Length(cssStyles);
|
|
SetLength(cssStyles, Result+1);
|
|
cssStyles[Result].styleID:= TextStyleID(p);
|
|
s:= '';
|
|
if Assigned(p) then
|
|
begin
|
|
// s += Format(' /* Cell Style "%s" */'#10, [cssStyles[Result].styleID]);
|
|
s += Format(' td.fs%d {%s', [Result,LineEnding]);
|
|
s += Format(' font-family: "%s";%s', [p^.FontName,LineEnding]);
|
|
s += Format(' font-size: %dpt;%s', [p^.FontSize,LineEnding]);
|
|
if (p^.FontStyle and $1) <> 0 then
|
|
s += ' font-style: italic;'+LineEnding;
|
|
if (p^.FontStyle and $2) <> 0 then
|
|
s += ' font-weight: bold;'+LineEnding;
|
|
if (p^.FontStyle and $4) <> 0 then
|
|
s += ' text-decoration: underline;'+LineEnding;
|
|
if (p^.FontColor <> clNone) and (p^.FontColor <> clDefault) and (p^.FontColor <> clBlack) then
|
|
s += Format(' color: %s;%s', [ColorToHex(p^.FontColor),LineEnding]);
|
|
if (p^.FillColor <> clNone) and (p^.FillColor <> clDefault) and (p^.FillColor <> clWhite) then
|
|
s += Format(' background-color: %s;%s', [ColorToHex(p^.FillColor),LineEnding]);
|
|
if (p^.Borders <> []) then
|
|
begin
|
|
case p^.BorderStyle of
|
|
frsSolid: s += ' border-style: solid;'+LineEnding;
|
|
frsDash: s += ' border-style: dashed;'+LineEnding;
|
|
frsDot,
|
|
frsDashDot,
|
|
frsDashDotDot: s += ' border-style: dotted;'+LineEnding;
|
|
frsDouble: s += ' border-style: double;'+LineEnding;
|
|
end;
|
|
if not (frbLeft in p^.Borders) then
|
|
s += ' border-left-style: none;'+LineEnding;
|
|
if not (frbTop in p^.Borders) then
|
|
s += ' border-top-style: none;'+LineEnding;
|
|
if not (frbRight in p^.Borders) then
|
|
s += ' border-right-style: none;'+LineEnding;
|
|
if not (frbBottom in p^.Borders) then
|
|
s += ' border-bottom-style: none;'+LineEnding;
|
|
s += Format(' border-width: %dpx;%s', [p^.BorderWidth,LineEnding]);
|
|
s += Format(' border-color: %s;%s', [ColorToHex(p^.BorderColor),LineEnding]);
|
|
end;
|
|
case p^.Alignment of
|
|
taRightJustify: s += ' text-align: right;';
|
|
taCenter: s += ' text-align: center;';
|
|
else
|
|
s += ' text-align: left;';
|
|
end;
|
|
s += ' } '+LineEnding+LineEnding;
|
|
end;
|
|
cssStyles[Result].styleInfo:= s;
|
|
end;
|
|
|
|
|
|
function TfrHTMExportFilter.ColorToHex(c: TColor): AnsiString;
|
|
const
|
|
SHexDigits: PChar = '0123456789ABCDEF';
|
|
var
|
|
r, g, b: byte;
|
|
begin
|
|
C:= ColorToRGB(C);
|
|
r:= Red(C);
|
|
g:= Green(C);
|
|
b:= Blue(C);
|
|
SetLength(Result{%H-}, 7); // #rrggbb
|
|
Result[1]:= '#';
|
|
Result[2]:= SHexDigits[Hi(r)];
|
|
Result[3]:= SHexDigits[Lo(r)];
|
|
Result[4]:= SHexDigits[Hi(g)];
|
|
Result[5]:= SHexDigits[Lo(g)];
|
|
Result[6]:= SHexDigits[Hi(b)];
|
|
Result[7]:= SHexDigits[Lo(b)];
|
|
end;
|
|
|
|
procedure TfrHTMExportFilter.AppendLine(const s: AnsiString);
|
|
begin
|
|
outputLines.Add(s);
|
|
end;
|
|
|
|
|
|
procedure TfrHTMExportFilter.InsertLine(const s: AnsiString; position: Integer);
|
|
begin
|
|
outputLines.Insert(position, s);
|
|
end;
|
|
|
|
procedure TfrHTMExportFilter.OnData(x, y: Integer; View: TfrView);
|
|
begin
|
|
FLastField := AddData(x, y, View);
|
|
end;
|
|
|
|
procedure TfrHTMExportFilter.OnText(X, Y: Integer; const Text: String;
|
|
View: TfrView);
|
|
begin
|
|
if FLastField^.Text='' then
|
|
FLastField^.Text := Text
|
|
else
|
|
FLastField^.Text := FLastField^.Text + '<br>' + Text;
|
|
end;
|
|
|
|
function TfrHTMExportFilter.GetviewText(View: TfrView): string;
|
|
begin
|
|
result := '';
|
|
end;
|
|
|
|
procedure TfrHTMExportFilter.CalcXCoords(var x, w: integer);
|
|
begin
|
|
x := round(x/UsedFont);
|
|
w := round(w/UsedFont);
|
|
end;
|
|
|
|
|
|
procedure TfrHTMExportFilter.OnEndDoc;
|
|
var
|
|
s: string;
|
|
x: Integer;
|
|
begin
|
|
s := '</body>'+LineEnding+'</html>'+LineEnding;
|
|
AppendLine(s);
|
|
for x:=0 to High(cssStyles) do
|
|
InsertLine(cssStyles[x].StyleInfo, styleStartLine + x);
|
|
for x:= 0 to Pred(outputLines.Count) do
|
|
if Length(outputLines[x])>0 then
|
|
Stream.Write(outputLines[x][1], Length(outputLines[x]));
|
|
end;
|
|
|
|
|
|
{ TfrHTMExport }
|
|
|
|
constructor TfrHTMExport.Create(aOwner: TComponent);
|
|
begin
|
|
inherited Create(aOwner);
|
|
|
|
frRegisterExportFilter(TfrHTMExportFilter, sHTMFile + ' (*.htm)', '*.htm');
|
|
end;
|
|
|
|
end.
|