{*****************************************}
{ }
{ 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:= '' + LineEnding;
AppendLine(s);
s:= '' + LineEnding +
'' + LineEnding +
'' + LineEnding +
'' + LineEnding +
'LazReport Exported Report' + LineEnding; // TODO: improve
AppendLine(s);
s:= '' + LineEnding +
'' + LineEnding +
'' + LineEnding +
'' + LineEnding + LineEnding;
AppendLine(s);
s:= '' + 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 := '';
if (Style and $2) <> 0 then
Result := Result + '';
if (Style and $4) <> 0 then
Result := Result + '';
end;
function GetEndHTMLFontStyle(Style: Integer): String;
begin
Result := '';
if (Style and $4) <> 0 then
Result := '';
if (Style and $2) <> 0 then
Result := Result + '';
if (Style and $1) <> 0 then
Result := Result + '';
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 := ''+LineEnding;
s += '';
for j:=1 to xPos.Count do
s += ' | ';
s += '
'+LineEnding;
AppendLine(s);
for i := 0 to n do
begin
p := PfrTextRec(Lines[i]);
s := '';
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 := '';
s4 := '';
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)cw then
if (xp-cw)>1 then
sEmpCells:= Format(' | ', [xp - cw])
else
sEmpCells:= ' | ';
if (xp2-xp)>1 then
sColSpan:= Format(' colspan=%d', [xp2 - xp]);
cw:= xp2;
s := Format('%s%s%s%s%s%s%s', [s, sEmpCells, sAlign, sStyle,
sColSpan, s1, s2, FormatCellText(p^.Text), s3, s4]);
p := p^.Next;
end;
if s = '' then
s += ' | ';
s += '
';
AppendLine(s + LineEnding);
end;
xPos.Free;
s := '
' + 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));
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;
s += ' } '+LineEnding+LineEnding;
end;
cssStyles[Result].styleInfo:= s;
end;
function TfrHTMExportFilter.ColorToHex(c: TColor): AnsiString;
var
s: AnsiString;
begin
s:= IntToHex(ColorToRGB(c), 8);
Result:= '#' + Copy(s, 7, 2) + Copy(s, 5, 2) + Copy(s, 3, 2);
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 + '
' + 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 := ''+LineEnding+''+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.