1 {*****
2
3 Copyright (c) 2012 Michał Gawrycki (michal.gawrycki(a.t.)gmsystems.pl
4 License: modified LGPL (see 'COPYING.modifiedLGPL.txt' in Lazarus directory)
5
6 *****}
7
8 unit LR_e_htmldiv;
9
10 {$mode objfpc}{$H+}
11
12 interface
13
14 uses
15 Classes, SysUtils, LR_Class, Graphics;
16
17 type
18 TfrHtmlDivExport = class(TComponent)
19
20 end;
21
22 { TfrHtmlDivExportFilter }
23
24 TfrHtmlDivExportFilter = class(TfrExportFilter)
25 private
26 FCurPage: integer;
27 FImgCnt: Integer;
28 FPageStyle: String;
29 FExportImages: Boolean;
30 FEmbeddedImages: Boolean;
31 procedure WriteString(AValue: string);
32 public
33 constructor Create(AStream: TStream); override;
34 procedure OnBeginDoc; override;
35 procedure OnEndDoc; override;
36 procedure OnBeginPage; override;
37 procedure OnEndPage; override;
38 procedure OnData(x, y: integer; View: TfrView); override;
39 procedure OnText(x, y: integer; const Text: string; View: TfrView); override;
40 property PageStyle: String read FPageStyle write FPageStyle;
41 property ExportImages: Boolean read FExportImages write FExportImages;
42 property EmbeddedImages: Boolean read FEmbeddedImages write FEmbeddedImages;
43 end;
44
45 implementation
46
47 uses
48 base64, LR_BarC;
49
50 const
51 HTML_REPORT_HEADER = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">'
52 + LineEnding + '<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">'
53 + LineEnding + '<head>' + LineEnding +
54 '<meta http-equiv="Content-Type" content="text/html; charset=utf-8"/>' +
55 LineEnding + '<title>%s</title>' + LineEnding + '<style type="text/css">' +
56 LineEnding + '.page {position: relative;%s}' + LineEnding + '.fV {position: absolute;}'
57 + LineEnding + '</style>' + LineEnding + '</head>' + LineEnding + '<body>' + LineEnding;
58 HTML_REPORT_END = '</body></html>';
59 HTML_PAGE_START =
60 '<div class="page" style="width:%dpx;min-width:%0:dpx;height:%dpx;min-height:%1:dpx;">'
61 + LineEnding;
62 HTML_PAGE_END = '</div>' + LineEnding;
63 HTML_BOX = '<div class="fV" style="%s"></div>' + LineEnding;
64 HTML_IMG1 = '<img class="fV" style="%s" src="';
65 HTML_IMG2 = ' " />' + LineEnding;
66 HTML_TEXT = '<div class="fV" style="%s">%s</div>' + LineEnding;
67
68 type
69
70 { TChunkStream }
71
72 TChunkStream = class(TOwnerStream)
73 private
74 FPos: Integer;
75 FChunkSize: Integer;
76 FSeparator: String;
77 public
78 constructor Create(ASource: TStream);
Writenull79 function Write(const Buffer; Count: Longint): Longint; override;
80 property ChunkSize: Integer read FChunkSize write FChunkSize;
81 property Separator: String read FSeparator write FSeparator;
82 end;
83
84 { TChunkStream }
85
86 constructor TChunkStream.Create(ASource: TStream);
87 begin
88 inherited Create(ASource);
89 FPos := 0;
90 FSeparator := LineEnding;
91 FChunkSize := 79;
92 end;
93
Writenull94 function TChunkStream.Write(const Buffer; Count: Longint): Longint;
95 var
96 I: Integer;
97 J,K: Integer;
98 begin
99 Result := Count;
100 I := 0;
101 if FPos > 0 then
102 begin
103 I := FChunkSize - FPos;
104 if I > Count then
105 begin
106 Source.Write(Buffer, Count);
107 FPos := FPos + Count;
108 Exit;
109 end
110 else
111 begin
112 Source.Write(Buffer, I);
113 Source.Write(FSeparator[1], Length(FSeparator));
114 FPos := 0;
115 end;
116 end;
117 if ((Count - I) > FChunkSize) then
118 J := (Count - I) div FChunkSize
119 else
120 begin
121 Source.Write(PChar(@Buffer)[I], Count - I);
122 FPos := (Count - I);
123 Exit;
124 end;
125 for K := 0 to J - 1 do
126 begin
127 Source.Write(PChar(@Buffer)[(K * FChunkSize)], FChunkSize);
128 Source.WriteBuffer(FSeparator[1], Length(FSeparator));
129 end;
130 J := (Count - I) mod FChunkSize;
131 if J > 0 then
132 begin
133 Source.Write(PChar(@Buffer)[((K + 1) * FChunkSize)], J);
134 FPos := J;
135 end;
136 end;
137
138 { TfrHtmlDivExportFilter }
139
ColorToCSSnull140 function ColorToCSS(AColor: TColor): string;
141 begin
142 Result := Format('#%.2x%.2x%.2x', [Red(AColor), Green(AColor), Blue(AColor)]);
143 end;
144
SizeToCSSnull145 function SizeToCSS(X, Y, W, H: integer): string;
146 begin
147 Result := Format(
148 'width:%dpx;min-width:%0:dpx;height:%dpx;min-height:%1:dpx;left:%dpx;top:%dpx;',
149 [W, H, X, Y]);
150 end;
151
152 procedure TfrHtmlDivExportFilter.WriteString(AValue: string);
153 begin
154 Stream.Write(AValue[1], Length(AValue));
155 end;
156
157 constructor TfrHtmlDivExportFilter.Create(AStream: TStream);
158 begin
159 inherited Create(AStream);
160 FCurPage := 0;
161 FImgCnt := 0;
162 FPageStyle := '';
163 FExportImages := True;
164 FEmbeddedImages := True;
165 end;
166
167 procedure TfrHtmlDivExportFilter.OnBeginDoc;
168 begin
169 WriteString(Format(HTML_REPORT_HEADER, [CurReport.Title, FPageStyle]));
170 end;
171
172 procedure TfrHtmlDivExportFilter.OnEndDoc;
173 begin
174 WriteString(HTML_REPORT_END);
175 end;
176
177 procedure TfrHtmlDivExportFilter.OnBeginPage;
178 begin
179 Inc(FCurPage);
180 WriteString(Format(HTML_PAGE_START, [CurReport.EMFPages[FCurPage - 1]^.PrnInfo.Pgw,
181 CurReport.EMFPages[FCurPage - 1]^.PrnInfo.Pgh]));
182 end;
183
184 procedure TfrHtmlDivExportFilter.OnEndPage;
185 begin
186 WriteString(HTML_PAGE_END);
187 end;
188
189 procedure TfrHtmlDivExportFilter.OnData(x, y: integer; View: TfrView);
190
BorderStyleToCSSnull191 function BorderStyleToCSS: string;
192 begin
193 case View.FrameStyle of
194 frsSolid, frsDouble: Result := 'solid';
195 frsDash, frsDashDot, frsDashDotDot: Result := 'dashed';
196 frsDot: Result := 'dotted';
197 end;
198 end;
199
200 var
201 W, H: integer;
202 BrdW: integer;
203 BLeft, BTop, BRight, BBottom: integer;
204 St: string;
205 B64: TBase64EncodingStream;
206 Png: TPortableNetworkGraphic;
207 BCBmp: TBitmap;
208 CS: TChunkStream;
209 begin
210 W := View.dx;
211 H := View.dy;
212
213 BrdW := Round(View.FrameWidth);
214
215 if frbLeft in View.Frames then
216 BLeft := BrdW
217 else
218 BLeft := 0;
219 if frbTop in View.Frames then
220 BTop := BrdW
221 else
222 BTop := 0;
223 if frbRight in View.Frames then
224 BRight := BrdW
225 else
226 BRight := 0;
227 if frbBottom in View.Frames then
228 BBottom := BrdW
229 else
230 BBottom := 0;
231
232 if BLeft > 0 then
233 Dec(W, BrdW);
234 if BTop > 0 then
235 Dec(H, BrdW);
236
237 St := SizeToCSS(X, Y, W, H);
238
239 St := St + Format('border-left:%0:dpx %4:s %5:s;border-top:%1:dpx %4:s %5:s;' +
240 'border-right:%2:dpx %4:s %5:s;border-bottom:%3:dpx %4:s %5:s;',
241 [BLeft, BTop, BRight, BBottom, BorderStyleToCSS, ColorToCSS(View.FrameColor)]);
242
243 if View.FillColor <> clNone then
244 St := St + 'background-color:' + ColorToCSS(View.FillColor) + ';';
245
246 if ExportImages and ((View is TfrPictureView) or (View is TfrCustomBarCodeView)) then
247 begin
248 WriteString(Format(HTML_IMG1, [St]));
249 Inc(FImgCnt);
250 if EmbeddedImages then
251 WriteString('data:image/png;base64,')
252 else
253 WriteString(ExtractFileName(TFileStream(Stream).FileName) + '_image_' + IntToStr(FImgCnt) + '.png');
254 Png := TPortableNetworkGraphic.Create;
255 if EmbeddedImages then
256 begin
257 CS := TChunkStream.Create(Stream);
258 B64 := TBase64EncodingStream.Create(CS);
259 end;
260 if View is TfrCustomBarCodeView then
261 begin
262 BCBmp := TfrCustomBarCodeView(View).GenerateBitmap;
263 Png.Assign(BCBmp);
264 BCBmp.Free;
265 end
266 else
267 if View is TfrPictureView then
268 begin
269 Png.SetSize(View.dx, View.dy);
270 if TfrPictureView(View).Stretched then
271 Png.Canvas.StretchDraw(Rect(0, 0, View.dx, View.dy), TfrPictureView(View).Picture.Graphic)
272 else
273 Png.Canvas.Draw(0, 0, TfrPictureView(View).Picture.Graphic);
274 end;
275 if EmbeddedImages then
276 begin
277 Png.SaveToStream(B64);
278 B64.Flush;
279 B64.Free;
280 CS.Free;
281 end
282 else
283 Png.SaveToFile(TFileStream(Stream).FileName + '_image_' + IntToStr(FImgCnt) + '.png');
284 Png.Free;
285 WriteString(HTML_IMG2);
286 end
287 else
288 WriteString(Format(HTML_BOX, [St]));
289 end;
290
291 procedure TfrHtmlDivExportFilter.OnText(x, y: integer; const Text: string; View: TfrView);
292 var
293 St: string;
294 begin
295 if Trim(Text) = '' then
296 Exit;
297 St := SizeToCSS(X, Y, View.dx, View.dy);
298 if View is TfrMemoView then
299 begin
300 St := St + 'font-family:''' + TfrMemoView(View).Font.Name +
301 ''';font-size:' + IntToStr(TfrMemoView(View).Font.Size) +
302 'pt;color:' + ColorToCSS(TfrMemoView(View).Font.Color) + ';';
303 if fsBold in TfrMemoView(View).Font.Style then
304 St := St + 'font-weight:bold;';
305 if fsItalic in TfrMemoView(View).Font.Style then
306 St := St + 'font-style:italic;';
307 if fsUnderline in TfrMemoView(View).Font.Style then
308 St := St + 'text-decoration:underline;';
309 St := St + 'text-align:';
310 case TfrMemoView(View).Alignment of
311 taLeftJustify: St := St + 'left;';
312 taCenter: St := St + 'center;';
313 taRightJustify: St := St + 'right;';
314 end;
315 end;
316 WriteString(Format(HTML_TEXT, [St, Text]));
317 end;
318
319 initialization
320 frRegisterExportFilter(TfrHtmlDivExportFilter, 'HTML (div-based) (*.html)', '*.html');
321
322 end.
323