1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
{*****
Copyright (c) 2012 Michał Gawrycki (michal.gawrycki(a.t.)gmsystems.pl
License: modified LGPL (see 'COPYING.modifiedLGPL.txt' in Lazarus directory)
*****}
unit LR_e_img;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LR_Class, Graphics
{$IFDEF LCLNOGUI}
, FPImage, FPWriteBMP, FPWritePNG, FPWriteJPEG
{$ENDIF}
;
type
TfrImageExport = class(TComponent)
end;
{ TfrImageExportFilter }
TfrImageExportFilter = class(TfrExportFilter)
private
{$IFDEF LCLNOGUI}
FBmp: TLazreportBitmap;
{$ELSE}
FBmp: TFPImageBitmap;
{$ENDIF}
FCurPage: Integer;
FFileName: String;
FFileExt: String;
FZoom: Extended;
FJQuality: TJPEGQualityRange;
FColor: TColor;
public
constructor Create(AStream: TStream); override;
destructor Destroy; override;
procedure OnBeginDoc; override;
procedure OnEndPage; override;
property Zoom: Extended read FZoom write FZoom;
property JPEGQuality: TJPEGQualityRange read FJQuality write FJQuality;
property BackgroundColor: TColor read FColor write FColor;
end;
implementation
{ TfrImageExportFilter }
constructor TfrImageExportFilter.Create(AStream: TStream);
begin
inherited Create(AStream);
FFileName := TFileStream(AStream).FileName;
FFileExt := LowerCase(ExtractFileExt(FFileName));
FFileName := ChangeFileExt(FFileName, '');
FZoom := 1;
FCurPage := 0;
FJQuality := 75;
FColor := clWhite;
{$IFDEF LCLNOGUI}
FBmp := TLazreportBitmap.create;
{$ELSE}
if FFileExt = '.jpg' then
FBmp := TJPEGImage.Create
else
if FFileExt = '.png' then
FBmp := TPortableNetworkGraphic.Create
else
FBmp := TBitmap.Create;
{$ENDIF}
end;
destructor TfrImageExportFilter.Destroy;
begin
FBmp.Free;
inherited Destroy;
end;
procedure TfrImageExportFilter.OnBeginDoc;
begin
{$IFNDEF LCLNOGUI}
if FBmp is TJPEGImage then
TJPEGImage(FBmp).CompressionQuality := FJQuality;
{$ENDIF}
end;
procedure TfrImageExportFilter.OnEndPage;
var
TmpVisible: Boolean;
{$IFDEF LCLNOGUI}
Writer: TFPCustomImageWriter;
{$ENDIF}
begin
Inc(FCurPage);
FBmp.Clear;
FBmp.SetSize(Round(CurReport.EMFPages[FCurPage - 1]^.PrnInfo.Pgw * FZoom),
Round(CurReport.EMFPages[FCurPage - 1]^.PrnInfo.Pgh * FZoom));
FBmp.Canvas.Brush.Color := FColor;
FBmp.Canvas.Brush.Style := bsSolid;
FBmp.Canvas.FillRect(0, 0, FBmp.Width, FBmp.Height);
TmpVisible := CurReport.EMFPages[FCurPage - 1]^.Visible;
CurReport.EMFPages[FCurPage - 1]^.Visible := True;
CurReport.EMFPages.Draw(FCurPage - 1, FBmp.Canvas, Rect(0, 0, FBmp.Width, FBmp.Height));
CurReport.EMFPages[FCurPage - 1]^.Visible := TmpVisible;
{$IFDEF LCLNOGUI}
case FFileExt of
'.jpg','.jpeg':
begin
Writer := TFPWriterJPEG.Create;
TFPWriterJPEG(Writer).CompressionQuality := JPEGQuality;
end;
'.png':
Writer := TFPWriterPNG.create;
else
Writer := nil;
end;
if FCurPage = 1 then
FBmp.SaveToStream(Stream, Writer)
else
FBmp.SaveToFile(FFileName + '_' + IntToStr(FCurPage) + FFileExt, Writer);
{$ELSE}
if FCurPage = 1 then
FBmp.SaveToStream(Stream)
else
FBmp.SaveToFile(FFileName + '_' + IntToStr(FCurPage) + FFileExt);
{$ENDIF}
end;
initialization
frRegisterExportFilter(TfrImageExportFilter, 'Bitmap file (*.bmp)', '*.bmp');
frRegisterExportFilter(TfrImageExportFilter, 'JPEG file (*.jpg)', '*.jpg');
frRegisterExportFilter(TfrImageExportFilter, 'PNG file (*.png)', '*.png');
end.
|
