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