3
Copyright (c) 2012 Michał Gawrycki (michal.gawrycki(a.t.)gmsystems.pl
4
License: modified LGPL (see 'COPYING.modifiedLGPL.txt' in Lazarus directory)
15
Classes, SysUtils, LR_Class, Graphics;
18
TfrImageExport = class(TComponent)
22
{ TfrImageExportFilter }
24
TfrImageExportFilter = class(TfrExportFilter)
31
FJQuality: TJPEGQualityRange;
34
constructor Create(AStream: TStream); override;
35
destructor Destroy; override;
36
procedure OnBeginDoc; override;
37
procedure OnEndPage; override;
38
property Zoom: Extended read FZoom write FZoom;
39
property JPEGQuality: TJPEGQualityRange read FJQuality write FJQuality;
40
property BackgroundColor: TColor read FColor write FColor;
45
{ TfrImageExportFilter }
47
constructor TfrImageExportFilter.Create(AStream: TStream);
49
inherited Create(AStream);
50
FFileName := TFileStream(AStream).FileName;
51
FFileExt := LowerCase(ExtractFileExt(FFileName));
52
FFileName := ChangeFileExt(FFileName, '');
57
if FFileExt = '.jpg' then
58
FBmp := TJPEGImage.Create
60
if FFileExt = '.png' then
61
FBmp := TPortableNetworkGraphic.Create
63
FBmp := TBitmap.Create;
66
destructor TfrImageExportFilter.Destroy;
72
procedure TfrImageExportFilter.OnBeginDoc;
74
if FBmp is TJPEGImage then
75
TJPEGImage(FBmp).CompressionQuality := FJQuality;
78
procedure TfrImageExportFilter.OnEndPage;
83
FBmp.SetSize(Round(CurReport.EMFPages[FCurPage - 1]^.PrnInfo.Pgw * FZoom),
84
Round(CurReport.EMFPages[FCurPage - 1]^.PrnInfo.Pgh * FZoom));
85
FBmp.Canvas.Brush.Color := FColor;
86
FBmp.Canvas.Brush.Style := bsSolid;
87
FBmp.Canvas.FillRect(0, 0, FBmp.Width, FBmp.Height);
88
TmpVisible := CurReport.EMFPages[FCurPage - 1]^.Visible;
89
CurReport.EMFPages[FCurPage - 1]^.Visible := True;
90
CurReport.EMFPages.Draw(FCurPage - 1, FBmp.Canvas, Rect(0, 0, FBmp.Width, FBmp.Height));
91
CurReport.EMFPages[FCurPage - 1]^.Visible := TmpVisible;
93
FBmp.SaveToStream(Stream)
95
FBmp.SaveToFile(FFileName + '_' + IntToStr(FCurPage) + FFileExt);
99
frRegisterExportFilter(TfrImageExportFilter, 'Bitmap file (*.bmp)', '*.bmp');
100
frRegisterExportFilter(TfrImageExportFilter, 'JPEG file (*.jpg)', '*.jpg');
101
frRegisterExportFilter(TfrImageExportFilter, 'PNG file (*.png)', '*.png');