paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-08 06:35:59 +02:00
Code Issues Packages Projects Releases Wiki Activity

LazReport, implemented css in html exporter, patch with changes from Ts.Petrov, issue #15011

Browse Source 
git-svn-id: trunk@23089 -
This commit is contained in:
jesus 2009-12-12 08:10:41 +00:00
parent fc25b96d25
commit 45f97fdb97
5 changed files with 351 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
components/lazreport/doc/contributors.txt
View File

@ -12,5 +12,6 @@ Luiz Americo (br)
Mattias Gaertner (de) Mattias Gaertner (de)
Olivier Guilbaud (fr) Olivier Guilbaud (fr)
Petr Smolik (cz) Petr Smolik (cz)
Ts. Petrov ( )
Vincent Snijders (nl) Vincent Snijders (nl)

12
components/lazreport/source/lr_class.pas
View File

@ -1108,9 +1108,15 @@ type
TfrTextRec = record TfrTextRec = record
Next: PfrTextRec; Next: PfrTextRec;
X: Integer; X: Integer;
Text: String[255]; W: Integer;
Text: string;
FontName: String[32]; FontName: String[32];
FontSize, FontStyle, FontColor, FontCharset, FillColor: Integer; FontSize, FontStyle, FontColor, FontCharset, FillColor: Integer;
Alignment: TAlignment;
Borders: TfrFrameBorders;
BorderColor: TColor;
BorderStyle: TfrFrameStyle;
BorderWidth: Integer;
Typ: Byte; Typ: Byte;
end; end;
@ -8489,6 +8495,7 @@ begin
else else
begin begin
p := TfrPreviewForm.Create(nil); p := TfrPreviewForm.Create(nil);
p.BorderIcons:=p.BorderIcons - [biMinimize];
{$IFDEF DebugLR} {$IFDEF DebugLR}
DebugLn('1 TfrPreviewForm.visible=',BooLToStr(p.Visible)); DebugLn('1 TfrPreviewForm.visible=',BooLToStr(p.Visible));
{$ENDIF} {$ENDIF}
@ -8957,7 +8964,7 @@ begin
inherited Create; inherited Create;
Stream := AStream; Stream := AStream;
Lines := TFpList.Create; Lines := TFpList.Create;
FBandTypes := [btMasterHeader, btMasterData]; FBandTypes := [btReportTitle..btNone];
end; end;
destructor TfrExportFilter.Destroy; destructor TfrExportFilter.Destroy;
@ -8979,6 +8986,7 @@ begin
begin begin
p1 := p; p1 := p;
p := p^.Next; p := p^.Next;
SetLength(p1^.Text, 0);
FreeMem(p1, SizeOf(TfrTextRec)); FreeMem(p1, SizeOf(TfrTextRec));
end; end;
end; end;

1
components/lazreport/source/lr_e_csv.pas
View File

@ -69,6 +69,7 @@ begin
FQuoteType := qtQuoteChar; FQuoteType := qtQuoteChar;
FQuoteChar := '"'; FQuoteChar := '"';
FSeparator := ';'; FSeparator := ';';
BandTypes := [btMasterHeader,btMasterData,btColumnHeader];
end; end;
procedure TfrCSVExportFilter.OnBeginPage; procedure TfrCSVExportFilter.OnBeginPage;

352
components/lazreport/source/lr_e_htm.pas
View File

@ -13,26 +13,50 @@ unit LR_E_HTM;
interface interface
{$I lr_vers.inc} {$I lr_vers.inc}
{$COPERATORS on}
uses uses
Classes, SysUtils, LResources, Classes, SysUtils, LResources,
Graphics,GraphType, Controls, Forms, Dialogs, LR_E_TXT, Graphics, GraphType, Controls, Forms, Dialogs, LR_E_TXT,
LCLType,LCLIntf,LR_Class; LCLType, LCLIntf, LR_Class;
type type
{ TStyleDesc }
TStyleDesc = record
styleID: AnsiString;
styleInfo: AnsiString;
end;
{ TfrHTMExport } { TfrHTMExport }
TfrHTMExport = class(TComponent) TfrHTMExport = class(TComponent)
public public
Constructor Create(aOwner : TComponent); override; constructor Create(aOwner: TComponent); override;
end; end;
{ TfrHTMExportFilter }
TfrHTMExportFilter = class(TfrTextExportFilter) TfrHTMExportFilter = class(TfrTextExportFilter)
private
cssStyles: array of TStyleDesc;
FUseCSS: boolean;
styleStartLine: integer;
outputLines: TStringList;
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: UTF8String);
procedure InsertLine(const s: UTF8String; position: Integer);
public public
constructor Create(AStream: TStream); override; constructor Create(AStream: TStream); override;
destructor Destroy; override; destructor Destroy; override;
procedure OnEndPage; override; procedure OnEndPage; override;
procedure OnEndDoc; override;
property UseCSS: boolean read FUseCSS write FUseCSS;
end; end;
@ -46,34 +70,47 @@ var
s: String; s: String;
begin begin
inherited Create(AStream); inherited Create(AStream);
outputLines:= TStringList.Create;
SetLength(cssStyles, 0);
s := '<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"' + LineEnding + s:= '<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">' + LineEnding;
' "http://www.w3.org/TR/html4/loose.dtd">' + LineEnding + AppendLine(s);
'<html><head>' + LineEnding + s:= '<html>' + LineEnding +
'<meta name="generator" content="LazReport html exporter">' + LineEnding + '<head>' + LineEnding +
'<title>LazReport Exported Report</title>' + LineEnding + // TODO: improve '<meta name="generator" content="LazReport html exporter">' + LineEnding +
'<meta http-equiv="Content-Type" content="text/html; charset=utf-8">' + LineEnding + '<meta http-equiv="content-type" content="text/html; charset=UTF-8">' + LineEnding +
'</head><body><table>' + 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;
Stream.Write(s[1], Length(s)); s:= '</style>' + LineEnding +
'<!-- CSS section end -->' + LineEnding +
'</head>' + LineEnding + LineEnding;
AppendLine(s);
s:= '<body bgColor="#FFFFFF">' + LineEnding;
AppendLine(s);
end; end;
destructor TfrHTMExportFilter.Destroy; destructor TfrHTMExportFilter.Destroy;
var
s: String;
begin begin
s := '</table></body></html>' + LineEnding; SetLength(cssStyles, 0);
Stream.Write(s[1], Length(s)); outputLines.Free;
inherited Destroy; inherited Destroy;
end; end;
{%REGION 'procedure TfrHTMExportFilter.OnEndPage' }
procedure TfrHTMExportFilter.OnEndPage; procedure TfrHTMExportFilter.OnEndPage;
var var
i, n: Integer; i, j, n, cw, xp, xp2: integer;
p: PfrTextRec; p: PfrTextRec;
s, s1, s2, s3: String; s, s1, s2, s3, s4, sp, sAlign, sStyle, sEmpCells, sColSpan: AnsiString;
xPos: TStringList;
function GetHTMLFontSize(Size: Integer): String; function GetHTMLFontSize(Size: integer): string;
begin begin
case Size of case Size of
6, 7: Result := '1'; 6, 7: Result := '1';
@ -86,64 +123,285 @@ var
end; end;
end; end;
function GetHTMLFontStyle(Style: Integer): String; function GetHTMLFontStyle(Style: integer): string;
begin begin
Result := ''; Result := '';
if (Style and $1) <> 0 then Result := '<i>'; if (Style and $1) <> 0 then
if (Style and $2) <> 0 then Result := Result + '<b>'; Result := '<i>';
if (Style and $4) <> 0 then Result := Result + '<u>'; if (Style and $2) <> 0 then
Result := Result + '<b>';
if (Style and $4) <> 0 then
Result := Result + '<u>';
end; end;
function GetEndHTMLFontStyle(Style: Integer): String; function GetEndHTMLFontStyle(Style: Integer): String;
begin begin
Result := ''; Result := '';
if (Style and $4) <> 0 then Result := '</u>'; if (Style and $4) <> 0 then
if (Style and $2) <> 0 then Result := Result + '</b>'; Result := '</u>';
if (Style and $1) <> 0 then Result := Result + '</i>'; 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 + '&nbsp;';
Result:= Result + Copy(sIn, c+1, Length(sIn)-c);
end; end;
begin begin
n := Lines.Count - 1; n := Lines.Count - 1;
while n >= 0 do while n >= 0 do
begin begin
if Lines[n] <> nil then break; if Lines[n] <> nil then
break;
Dec(n); Dec(n);
end; end;
xPos:= TStringList.Create;
xPos.Sorted:= true;
for i := 0 to n do for i := 0 to n do
begin begin
p := PfrTextRec(Lines[i]); p := PfrTextRec(Lines[i]);
s := '';
while p <> nil do while p <> nil do
begin begin
s1 := ''; s2 := ''; s3 := ''; 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%">'+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 if (p^.FontColor = clWhite) or (p^.FontColor = clNone) then
p^.FontColor := clBlack; p^.FontColor := clBlack;
if p^.FontColor <> clBlack then
if FUseCSS then
begin begin
s1 := IntToHex(p^.FontColor, 6); sStyle:= Format(' class="fs%d"', [StyleIndex(p, true)]);
s1 := 'Color="#' + Copy(s1, 5, 2) + Copy(s1, 3, 2) + end
Copy(s1, 1, 2) + '"'; else
end;
// 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 begin
s2 := GetHTMLFontStyle(p^.FontStyle); if p^.FontColor <> clBlack then
s3 := GetEndHTMLFontStyle(p^.FontStyle); 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; end;
if s1 <> '' then s1 := '<Font ' + s1 + '>';
s := s + '<td>' + s1 + s2 + p^.Text + s3; case p^.Alignment of
if s1 <> '' then s := s + '</Font>'; taRightJustify: sAlign:= ' align="right"';
s := s + '</td>'; taCenter: sAlign:= ' align="center"';
end;
sp:= Format('%.5d', [p^.X]);
xp:= xPos.IndexOf(sp);
sp:= Format('%.5d', [p^.X + p^.W]);
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; p := p^.Next;
end; end;
if s='' then
s := '<td></td>'; if s = '<tr>' then
s := '<tr>' + s + '</tr>' + LineEnding; s += '<td></td>';
Stream.Write(s[1], Length(s));
s += '</tr>';
AppendLine(s + LineEnding);
end; 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));
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: UTF8String);
begin
outputLines.Add(s);
end;
procedure TfrHTMExportFilter.InsertLine(const s: UTF8String; position: Integer);
begin
outputLines.Insert(position, s);
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; end;

59
components/lazreport/source/lr_e_txt.pas
View File

@ -15,9 +15,8 @@ interface
{$I lr_vers.inc} {$I lr_vers.inc}
uses uses
Classes, SysUtils, LResources, Classes, SysUtils, LResources, Graphics, GraphType, Controls, Forms, Dialogs,
Graphics,GraphType, Controls, Forms, Dialogs, LCLType, LCLIntf, LR_Class;
LCLType,LCLIntf,LR_Class;
type type
@ -25,7 +24,7 @@ type
TfrTextExport = class(TComponent) TfrTextExport = class(TComponent)
public public
Constructor Create(aOwner : TComponent); override; constructor Create(aOwner: TComponent); override;
end; end;
{ TfrTextExportFilter } { TfrTextExportFilter }
@ -106,21 +105,22 @@ begin
n := Lines.Count - 1; n := Lines.Count - 1;
while n >= 0 do while n >= 0 do
begin begin
if Lines[n] <> nil then break; if Lines[n] <> nil then
break;
Dec(n); Dec(n);
end; end;
for i := 0 to n do for i := 0 to n do
begin begin
s := ''; s := '';
tc1 := 0; tc1:= 0;
p := PfrTextRec(Lines[i]); p := PfrTextRec(Lines[i]);
while p <> nil do while p <> nil do
begin begin
x := Round(p^.X / 6.5); x := Round(p^.X / 6.5);
s := s + Dup(x - tc1) + p^.Text; s := s + Dup(x - tc1) + p^.Text;
tc1 := x + Length(p^.Text); tc1:= x + Length(p^.Text);
p := p^.Next; p := p^.Next;
end; end;
s := s + LineEnding; s := s + LineEnding;
Stream.Write(s[1], Length(s)); Stream.Write(s[1], Length(s));
@ -131,10 +131,11 @@ end;
procedure TfrTextExportFilter.OnBeginPage; procedure TfrTextExportFilter.OnBeginPage;
var var
i: Integer; i: integer;
begin begin
ClearLines; ClearLines;
for i := 0 to 200 do Lines.Add(nil); for i := 0 to 200 do
Lines.Add(nil);
end; end;
procedure TfrTextExportFilter.OnText(X, Y: Integer; const Text: String; procedure TfrTextExportFilter.OnText(X, Y: Integer; const Text: String;
@ -142,30 +143,38 @@ procedure TfrTextExportFilter.OnText(X, Y: Integer; const Text: String;
var var
p, p1, p2: PfrTextRec; p, p1, p2: PfrTextRec;
begin begin
if View = nil then Exit; if View = nil then
Exit;
Y := Round(Y / UsedFont); Y := Round(Y / UsedFont);
p1 := PfrTextRec(Lines[Y]); p1:= PfrTextRec(Lines[Y]);
GetMem(p, SizeOf(TfrTextRec)); GetMem(p, SizeOf(TfrTextRec));
FillChar(p^, SizeOf(TfrTextRec), 0); FillChar(p^, SizeOf(TfrTextRec), 0);
p^.Next := nil; p^.Next := nil;
p^.X := X; p^.X := Round(View.X / UsedFont);
p^.W := Round(View.Width / UsedFont);
p^.Text := Text; p^.Text := Text;
p^.FillColor := View.FillColor;
p^.Borders := View.Frames;
p^.BorderColor:= View.FrameColor;
p^.BorderStyle:= View.FrameStyle;
p^.BorderWidth:= Round(View.FrameWidth);
if View is TfrMemoView then if View is TfrMemoView then
with View as TfrMemoView do with View as TfrMemoView do
begin begin
p^.FontName := Font.Name; p^.FontName := Font.Name;
p^.FontSize := Font.Size; p^.FontSize := Font.Size;
p^.FontStyle := frGetFontStyle(Font.Style); p^.FontStyle := frGetFontStyle(Font.Style);
p^.FontColor := Font.Color; p^.FontColor := Font.Color;
p^.FontCharset := Font.Charset; p^.FontCharset := Font.Charset;
p^.Alignment := Alignment;
end; end;
p^.FillColor := View.FillColor;
if p1 = nil then if p1 = nil then
Lines[Y] := TObject(p) Lines[Y] := TObject(p)
else else
begin begin
p2 := p1; p2 := p1;
while (p1 <> nil) and (p1^.X < p^.X) do while (p1 <> nil) and (p1^.X <= p^.X) do
begin begin
p2 := p1; p2 := p1;
p1 := p1^.Next; p1 := p1^.Next;
@ -173,12 +182,12 @@ begin
if p2 <> p1 then if p2 <> p1 then
begin begin
p2^.Next := p; p2^.Next := p;
p^.Next := p1; p^.Next := p1;
end end
else else
begin begin
Lines[Y] := TObject(p); Lines[Y] := TObject(p);
p^.Next := p1; p^.Next := p1;
end; end;
end; end;
end; end;