Delphi/FastReport_2022_VCL
Delphi/FastReport_2022_VCL
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
b867fa72b3
FastReport_2022_VCL/LibD28x64/frxExportImage.pas

1278 lines
35 KiB
ObjectPascal
Raw Normal View History

Inicijalizacija
2024-01-01 16:13:08 +01:00
{******************************************}
{ }
{ FastReport VCL }
{ Picture Export Filters }
{ }
{ Copyright (c) 1998-2021 }
{ by Fast Reports Inc. }
{ }
{******************************************}
unit frxExportImage;
interface
{$I frx.inc}
uses
{$IFNDEF FPC}
Windows, Messages,
{$ELSE}
LCLType, LCLIntf,
{$ENDIF}
SysUtils, Classes, Graphics, frxClass, frxPictureGraphics, frxExportBaseDialog
{$IFDEF Delphi6}
, Variants
{$ENDIF};
{$IFNDEF FPC}
procedure GIFSaveToFile(const FileName: String; const Bitmap: TBitmap);
{$ENDIF}
type
{ TfrxCustomImageExport }
TfrxCustomImageExport = class(TfrxBaseDialogExportFilter)
private
FBitmap: TBitmap;
FCrop: Boolean;
FCurrentPage: Integer;
FJPEGQuality: Integer;
FMaxX: Integer;
FMaxY: Integer;
FMinX: Integer;
FMinY: Integer;
FMonochrome: Boolean;
FResolution: Integer;
FCurrentRes: Integer;
FSeparate: Boolean;
FYOffset: Integer;
FFileSuffix: String;
FFirstPage: Boolean;
FExportNotPrintable: Boolean;
function SizeOverflow(const Val: Extended): Boolean;
protected
FPaperWidth: Double;
FPaperHeight: Double;
FDiv: Extended;
FGHelper: TfrxCustomGraphicFormatClass;
FPicFormatName: String;
procedure Save;
procedure SaveToStream(const aStream: TStream); virtual;
procedure FinishExport; virtual;
procedure InitPictureFormat(const FormatName: String);
public
constructor Create(AOwner: TComponent); override;
function Start: Boolean; override;
procedure Finish; override;
procedure FinishPage(Page: TfrxReportPage; Index: Integer); override;
procedure StartPage(Page: TfrxReportPage; Index: Integer); override;
procedure ExportObject(Obj: TfrxComponent); override;
function IsProcessInternal: Boolean; override;
class function ExportDialogClass: TfrxBaseExportDialogClass; override;
property JPEGQuality: Integer read FJPEGQuality write FJPEGQuality default 90;
property CropImages: Boolean read FCrop write FCrop default False;
property Monochrome: Boolean read FMonochrome write FMonochrome default False;
property Resolution: Integer read FResolution write FResolution;
property SeparateFiles: Boolean read FSeparate write FSeparate;
property ExportNotPrintable: Boolean read FExportNotPrintable write FExportNotPrintable;
property OverwritePrompt;
end;
{$IFNDEF FPC}
{$IFDEF DELPHI16}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF}
TfrxEMFExport = class(TfrxCustomImageExport)
private
FMetafile: TMetafile;
FMetafileCanvas: TMetafileCanvas;
protected
procedure FinishExport; override;
procedure SaveToStream(const aStream: TStream); override;
public
function Start: Boolean; override;
procedure StartPage(Page: TfrxReportPage; Index: Integer); override;
procedure ExportObject(Obj: TfrxComponent); override;
constructor Create(AOwner: TComponent); override;
class function GetDescription: String; override;
published
property CropImages;
property OverwritePrompt;
end;
{$ENDIF}
{$IFDEF DELPHI16}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF}
TfrxBMPExport = class(TfrxCustomImageExport)
private
protected
procedure SaveToStream(const aStream: TStream); override;
public
constructor Create(AOwner: TComponent); override;
class function GetDescription: String; override;
published
property CropImages;
property Monochrome;
property OverwritePrompt;
end;
{$IFDEF DELPHI16}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF}
TfrxTIFFExport = class(TfrxCustomImageExport)
{$IFNDEF FPC}
private
FMultiImage: Boolean;
FIsStreamCreated: Boolean;
{ Saves a picture to a TIFF stream.
Arguments:
- Split - if set, the picture will be splitted into
chunks that fit into a standard page (its dimensions are in
FPaperWidth and FPaperHeight in millimeters)
- WriteHeader - a TIFF stream is capable to store several
images. If the first image is being written to a stream,
WriteHeader must be True. If an additional image is to be
written to a non empty TIFF stream, then WriteHeader must
be False. }
procedure SaveTiffToStream(const Stream: TStream; const Bitmap: TBitmap;
Split: Boolean; WriteHeader: Boolean = True);
{$ENDIF}
protected
procedure SaveToStream(const aStream: TStream); override;
public
constructor Create(AOwner: TComponent); override;
class function GetDescription: String; override;
{$IFNDEF FPC}
function Start: Boolean; override;
procedure Finish; override;
procedure FinishPage(Page: TfrxReportPage; Index: Integer); override;
procedure StartPage(Page: TfrxReportPage; Index: Integer); override;
{$ENDIF}
published
property CropImages;
property Monochrome;
property OverwritePrompt;
{ It's possible to store a few picture in a single TIFF image.
If MultiPage = True, then all pictures larger than a standard
print page (its dimensions are stored in FPaperWidth and FPaperHeight
in millimeters) will be splitted into a few standard pages and
then saved to the TIFF image. }
{$IFNDEF FPC}
property MultiImage: Boolean read FMultiImage write FMultiImage default False;
{$ENDIF}
end;
{$IFDEF DELPHI16}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF}
TfrxJPEGExport = class(TfrxCustomImageExport)
public
constructor Create(AOwner: TComponent); override;
class function GetDescription: String; override;
published
property JPEGQuality;
property CropImages;
property Monochrome;
property OverwritePrompt;
end;
{$IFDEF DELPHI16}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF}
{$IFNDEF FPC}
TfrxGIFExport = class(TfrxCustomImageExport)
protected
procedure SaveToStream(const aStream: TStream); override;
public
constructor Create(AOwner: TComponent); override;
class function GetDescription: String; override;
published
property CropImages;
property Monochrome;
property OverwritePrompt;
end;
{$ENDIF}
{$IFDEF DELPHI16}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF}
TfrxPNGExport = class(TfrxCustomImageExport)
public
constructor Create(AOwner: TComponent); override;
class function GetDescription: String; override;
published
property CropImages;
property Monochrome;
property OverwritePrompt;
end;
implementation
uses
frxUtils, frxFileUtils, frxRes, frxIOTransportIntf, frxrcExports,
{$IFNDEF FPC}
GIF,
{$ENDIF}
frxExportImageDialog;
{$IFNDEF FPC}
type
PDirEntry = ^TDirEntry;
TDirEntry = record
_Tag: Word;
_Type: Word;
_Count: LongInt;
_Value: LongInt;
end;
{$ENDIF}
const
{$IFNDEF FPC}
EMF_DIV = 0.911;
TifHeader: array[0..7] of Byte = (
$49, $49, $2A, $00, $08, $00, $00, $00);
{$ENDIF}
{ Here http://www.fileformat.info/format/bmp/egff.htm
is written that BMP file can have size up to 32K x 32K }
MaxBitmapHeight = 30000;
MaxBitmapWidth = 30000;
{$IFNDEF FPC}
MAXBITSCODES = 12;
HSIZE = 5003;
NullString: array[0..3] of Byte = ($00, $00, $00, $00);
Software: array[0..9] of AnsiChar = ('F', 'a', 's', 't', 'R', 'e', 'p', 'o', 'r', 't');
code_mask: array [0..16] of cardinal = ($0000, $0001, $0003, $0007, $000F,
$001F, $003F, $007F, $00FF, $01FF, $03FF, $07FF, $0FFF,
$1FFF, $3FFF, $7FFF, $FFFF);
BitsPerSample: array[0..2] of Word = ($0008, $0008, $0008);
D_BW_C: array[0..13] of TDirEntry = (
(_Tag: $00FE; _Type: $0004; _Count: $00000001; _Value: $00000000),
(_Tag: $0100; _Type: $0003; _Count: $00000001; _Value: $00000000),
(_Tag: $0101; _Type: $0003; _Count: $00000001; _Value: $00000000),
(_Tag: $0102; _Type: $0003; _Count: $00000001; _Value: $00000001),
(_Tag: $0103; _Type: $0003; _Count: $00000001; _Value: $00000001),
(_Tag: $0106; _Type: $0003; _Count: $00000001; _Value: $00000001),
(_Tag: $0111; _Type: $0004; _Count: $00000001; _Value: $00000000),
(_Tag: $0115; _Type: $0003; _Count: $00000001; _Value: $00000001),
(_Tag: $0116; _Type: $0004; _Count: $00000001; _Value: $00000000),
(_Tag: $0117; _Type: $0004; _Count: $00000001; _Value: $00000000),
(_Tag: $011A; _Type: $0005; _Count: $00000001; _Value: $00000000),
(_Tag: $011B; _Type: $0005; _Count: $00000001; _Value: $00000000),
(_Tag: $0128; _Type: $0003; _Count: $00000001; _Value: $00000002),
(_Tag: $0131; _Type: $0002; _Count: $0000000A; _Value: $00000000));
D_COL_C: array[0..14] of TDirEntry = (
(_Tag: $00FE; _Type: $0004; _Count: $00000001; _Value: $00000000),
(_Tag: $0100; _Type: $0003; _Count: $00000001; _Value: $00000000),
(_Tag: $0101; _Type: $0003; _Count: $00000001; _Value: $00000000),
(_Tag: $0102; _Type: $0003; _Count: $00000001; _Value: $00000008),
(_Tag: $0103; _Type: $0003; _Count: $00000001; _Value: $00000001),
(_Tag: $0106; _Type: $0003; _Count: $00000001; _Value: $00000003),
(_Tag: $0111; _Type: $0004; _Count: $00000001; _Value: $00000000),
(_Tag: $0115; _Type: $0003; _Count: $00000001; _Value: $00000001),
(_Tag: $0116; _Type: $0004; _Count: $00000001; _Value: $00000000),
(_Tag: $0117; _Type: $0004; _Count: $00000001; _Value: $00000000),
(_Tag: $011A; _Type: $0005; _Count: $00000001; _Value: $00000000),
(_Tag: $011B; _Type: $0005; _Count: $00000001; _Value: $00000000),
(_Tag: $0128; _Type: $0003; _Count: $00000001; _Value: $00000002),
(_Tag: $0131; _Type: $0002; _Count: $0000000A; _Value: $00000000),
(_Tag: $0140; _Type: $0003; _Count: $00000300; _Value: $00000008));
D_RGB_C: array[0..14] of TDirEntry = (
(_Tag: $00FE; _Type: $0004; _Count: $00000001; _Value: $00000000),
(_Tag: $0100; _Type: $0003; _Count: $00000001; _Value: $00000000),
(_Tag: $0101; _Type: $0003; _Count: $00000001; _Value: $00000000),
(_Tag: $0102; _Type: $0003; _Count: $00000003; _Value: $00000008),
(_Tag: $0103; _Type: $0003; _Count: $00000001; _Value: $00000001),
(_Tag: $0106; _Type: $0003; _Count: $00000001; _Value: $00000002),
(_Tag: $0111; _Type: $0004; _Count: $00000001; _Value: $00000000),
(_Tag: $0115; _Type: $0003; _Count: $00000001; _Value: $00000003),
(_Tag: $0116; _Type: $0004; _Count: $00000001; _Value: $00000000),
(_Tag: $0117; _Type: $0004; _Count: $00000001; _Value: $00000000),
(_Tag: $011A; _Type: $0005; _Count: $00000001; _Value: $00000000),
(_Tag: $011B; _Type: $0005; _Count: $00000001; _Value: $00000000),
(_Tag: $011C; _Type: $0003; _Count: $00000001; _Value: $00000001),
(_Tag: $0128; _Type: $0003; _Count: $00000001; _Value: $00000002),
(_Tag: $0131; _Type: $0002; _Count: $0000000A; _Value: $00000000));
{$ENDIF}
{ TfrxCustomImageExport }
constructor TfrxCustomImageExport.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FPicFormatName := 'BMP';
FCrop := True;
FJPEGQuality := 90;
FResolution := 96;
FSeparate := True;
FExportNotPrintable := False;
CropImages := False;
OpenAfterExport := False;
end;
function TfrxCustomImageExport.Start: Boolean;
begin
InitPictureFormat(FPicFormatName);
CurPage := False;
FCurrentPage := 0;
FYOffset := 0;
if not FSeparate then
begin
FBitmap := TBitmap.Create;
FBitmap.Canvas.Lock;
try
FCurrentRes := FBitmap.Canvas.Font.PixelsPerInch;
FDiv := FResolution / FCurrentRes;
FBitmap.Canvas.Brush.Color := clWhite;
finally
FBitmap.Canvas.Unlock;
end;
FBitmap.Monochrome := Monochrome;
FMaxX := 0;
FMaxY := 0;
FFirstPage := True;
end;
Result := (FileName <> '') or (Stream <> nil);
end;
procedure TfrxCustomImageExport.StartPage(Page: TfrxReportPage; Index: Integer);
var
i: Integer;
h, w: Extended;
begin
Inc(FCurrentPage);
if FSeparate then
begin
FBitmap := TBitmap.Create;
FBitmap.Canvas.Lock;
try
FCurrentRes := FBitmap.Canvas.Font.PixelsPerInch;
FDiv := FResolution / FCurrentRes;
FBitmap.Canvas.Brush.Color := clWhite;
finally
FBitmap.Canvas.Unlock;
end;
FBitmap.Monochrome := Monochrome;
FBitmap.Width := Round(Page.Width * FDiv);
FBitmap.Height := Round(Page.Height * FDiv);
FMaxX := 0;
FMaxY := 0;
FMinX := FBitmap.Width;
FMinY := FBitmap.Height;
{$IFDEF FPC}
FBitmap.Canvas.Lock;
try
FBitmap.Canvas.FillRect(0, 0, FMinX, FMinY);
finally
FBitmap.Canvas.Unlock;
end;
{$ENDIF}
end
else if FFirstpage then
with FBitmap do
begin
w := 0;
h := 0;
for i := 0 to Report.PreviewPages.Count - 1 do
with Report.PreviewPages.Page[i] do
begin
if w < Width then
w := Width;
h := h + Height;
end;
w := w * FDiv;
h := h * FDiv;
if SizeOverflow(w) then
w := MaxBitmapWidth;
if SizeOverflow(h) then
h := MaxBitmapHeight;
Width := Round(w);
Height := Round(h);
FMinX := Width;
FMinY := Height;
{$IFDEF FPC}
FBitmap.Canvas.Lock;
try
FBitmap.Canvas.FillRect(0, 0, FMinX, FMinY);
finally
FBitmap.Canvas.Unlock;
end;
{$ENDIF}
FFirstPage := False;
end;
end;
class function TfrxCustomImageExport.ExportDialogClass: TfrxBaseExportDialogClass;
begin
Result := TfrxIMGExportDialog;
end;
procedure TfrxCustomImageExport.ExportObject(Obj: TfrxComponent);
var
z: Integer;
begin
if (Obj is TfrxView) and (FExportNotPrintable or TfrxView(Obj).Printable) then
begin
if not IsPageBG(Obj) then
begin
z := Round(Obj.AbsLeft * FDiv);
if z < FMinX then
FMinX := z;
z := FYOffset + Round(Obj.AbsTop * FDiv);
if z < FMinY then
FMinY := z;
z := Round((Obj.AbsLeft + Obj.Width) * FDiv) + 1;
if z > FMaxX then
FMaxX := z;
z := FYOffset + Round((Obj.AbsTop + Obj.Height) * FDiv) + 1;
if z > FMaxY then
FMaxY := z;
end;
FBitmap.Canvas.Lock;
try
TfrxView(Obj).Draw(FBitmap.Canvas, FDiv, FDiv, 0, FYOffset);
finally
FBitmap.Canvas.Unlock;
end;
end;
end;
procedure TfrxCustomImageExport.InitPictureFormat(const FormatName: String);
begin
FGHelper := GetGraphicFormats.FindByName(FormatName, [gcSaveTo, gcConvert]);
if not Assigned(FGHelper) then raise Exception.Create(Format('Picture format %s not found.', [FormatName]));
end;
function TfrxCustomImageExport.IsProcessInternal: Boolean;
begin
Result:= False;
end;
procedure TfrxCustomImageExport.FinishPage(Page: TfrxReportPage; Index: Integer);
begin
FPaperWidth := Page.PaperWidth;
FPaperHeight := Page.PaperHeight;
if FSeparate then
FinishExport
else
FYOffset := FYOffset + Round(Page.Height * FDiv);
end;
procedure TfrxCustomImageExport.Finish;
begin
if not FSeparate then
FinishExport;
FGHelper := nil;
end;
procedure TfrxCustomImageExport.Save;
var
s: TStream;
begin
if FSeparate then
FFileSuffix := '.' + IntToStr(FCurrentPage)
else
FFileSuffix := '';
try
if Stream <> nil then
s := Stream
else
s := IOTransport.GetStream(ChangeFileExt(FileName, FFileSuffix + DefaultExt));
try
if Stream = nil then
begin
if not IOTransport.DoFilterProcessStream(s, Self) then
SaveToStream(s);
end
else
SaveToStream(s);
finally
if Stream = nil then
IOTransport.FreeStream(s);
end;
except
on e: Exception do
case Report.EngineOptions.NewSilentMode of
simSilent:
Report.Errors.Add(e.Message);
simMessageBoxes:
frxErrorMsg(e.Message);
simReThrow:
raise;
end;
end;
end;
procedure TfrxCustomImageExport.SaveToStream(const aStream: TStream);
var
Image: TGraphic;
begin
try
Image := FGHelper.ConvertFrom(FBitmap, pf24bit, FJPEGQuality);
try
Image.SaveToStream(aStream);
finally
Image.Free;
end;
except
on e: Exception do
case Report.EngineOptions.NewSilentMode of
simSilent:
Report.Errors.Add(e.Message);
simMessageBoxes:
frxErrorMsg(e.Message);
simReThrow:
raise;
end;
end;
end;
procedure TfrxCustomImageExport.FinishExport;
var
RFrom, RTo: TRect;
begin
try
if FCrop then
begin
RFrom := Rect(FMinX, FMinY, FMaxX, FMaxY);
RTo := Rect(0, 0, FMaxX - FMinX, FMaxY - FMinY);
FBitmap.Canvas.Lock;
try
FBitmap.Canvas.CopyRect(RTo, FBitmap.Canvas, RFrom);
finally
FBitmap.Canvas.Unlock;
end;
FBitmap.Width := FMaxX - FMinX;
FBitmap.Height := FMaxY - FMinY;
end;
Save;
finally
FBitmap.Free;
end;
end;
function TfrxCustomImageExport.SizeOverflow(const Val: Extended): Boolean;
begin
Result := Val > MaxBitmapHeight;
end;
{ TfrxBMPExport }
constructor TfrxBMPExport.Create(AOwner: TComponent);
begin
inherited;
FPicFormatName := 'BMP';
FilterDesc := frxResources.Get('BMPexportFilter');
DefaultExt := '.bmp';
end;
class function TfrxBMPExport.GetDescription: String;
begin
Result := frxResources.Get('BMPexport');
end;
procedure TfrxBMPExport.SaveToStream(const aStream: TStream);
begin
inherited;
FBitmap.SaveToStream(aStream);
end;
{ TfrxTIFFExport }
constructor TfrxTIFFExport.Create(AOwner: TComponent);
begin
inherited;
FilterDesc := frxResources.Get('TIFFexportFilter');
DefaultExt := '.tif';
{$IFNDEF FPC}
FIsStreamCreated := False;
{$ENDIF}
end;
{$IFNDEF FPC}
procedure TfrxTIFFExport.Finish;
begin
if not FMultiImage then
begin
inherited;
Exit;
end;
if FIsStreamCreated then
begin
// Stream.Free;
IOTransport.FreeStream(Stream);
Stream := nil;
FIsStreamCreated := False;
end;
end;
procedure TfrxTIFFExport.FinishPage(Page: TfrxReportPage; Index: Integer);
begin
if not FMultiImage then
begin
inherited;
Exit;
end;
try
SaveTiffToStream(Stream, FBitmap, False, FFirstPage);
finally
FBitmap.Free;
end;
FFirstPage := False;
end;
{$ENDIF}
class function TfrxTIFFExport.GetDescription: String;
begin
Result := frxResources.Get('TIFFexport');
end;
procedure TfrxTIFFExport.SaveToStream(const aStream: TStream);
{$IFDEF FPC}
var
Image: TTiffImage;
{$ENDIF}
begin
try
{$IFNDEF FPC}
SaveTiffToStream(aStream, FBitmap, MultiImage)
{$ELSE}
Image := TTiffImage.Create;
try
Image.Assign(FBitmap);
Image.SaveToStream(aStream);
finally
Image.Free;
end;
{$ENDIF}
except
on e: Exception do
case Report.EngineOptions.NewSilentMode of
simSilent:
Report.Errors.Add(e.Message);
simMessageBoxes:
frxErrorMsg(e.Message);
simReThrow:
raise;
end;
end;
end;
{$IFNDEF FPC}
procedure TfrxTIFFExport.SaveTIFFToStream(const Stream: TStream; const Bitmap: TBitmap;
Split: Boolean; WriteHeader: Boolean);
function Min(a, b: Integer): Integer;
begin
if a < b then
Result := a
else
Result := b;
end;
var
i, k, x, y: Integer;
dib_f: Boolean;
Header, Bits, BitsPtr, TmpBitsPtr, NewBits: PAnsiChar;
HeaderSize, BitsSize: DWORD;
Width, Height, DataWidth, BitCount: Integer;
MapRed, MapGreen, MapBlue: array[0..255, 0..1] of Byte;
ColTabSize, BmpWidth: Integer;
Red, Blue, Green: AnsiChar;
O_XRes, O_YRes, O_Soft, O_Strip, O_Dir, O_BPS: LongInt;
RGB: Word;
Res: Word;
NoOfDirs: array[0..1] of Byte;
D_BW: array[0..13] of TDirEntry;
D_COL: array[0..14] of TDirEntry;
D_RGB: array[0..14] of TDirEntry;
Res_Value: array[0..7] of Byte;
Page: TBitmap;
Source, Dest: TRect;
NextIfd: Integer;
begin
if Bitmap.Handle = 0 then
Exit;
{ split a big image into smaller images that fit
into a standard print page }
{ remove part in spli condion - doesn't used anymore }
if Split then
begin
Width := Trunc(FPaperWidth / 25.4 * 96) + 1;
Height := Trunc(FPaperHeight / 25.4 * 96) + 1;
y := 0;
repeat
x := 0;
repeat
/// with Source do doesn't work in XE2 and above , compiler bug ???
begin
Source.Left := x;
Source.Top := y;
Source.Right := Min(x + Width, Bitmap.Width) - 1;
Source.Bottom := Min(y + Height, Bitmap.Height) - 1;
end;
///with Dest do
begin
Dest.Left := 0;
Dest.Top := 0;
Dest.Right := Source.Right - Source.Left;
Dest.Bottom := Source.Bottom - Source.Top;
end;
Page := TBitmap.Create;
with Page do
begin
Canvas.Brush.Color := clWhite;
Monochrome := Monochrome;
// SetSize(Dest.Right + 1, Dest.Bottom + 1);
Width := Dest.Right + 1;
Height := Dest.Bottom + 1;
Canvas.CopyRect(Dest, Bitmap.Canvas, Source);
end;
SaveTiffToStream(Stream, Page, False, WriteHeader);
WriteHeader := False;
Page.Free;
Inc(x, Width);
until x > Bitmap.Width;
Inc(y, Height);
until y > Bitmap.Height;
Exit;
end;
NoOfDirs[1] := 0;
Res := FResolution * 10;
Res_Value[0] := Res and $ff;
Res_Value[1] := Res shr 8;
Res_Value[2] := 0;
Res_Value[3] := 0;
Res_Value[4] := $0A;
Res_Value[5] := 0;
Res_Value[6] := 0;
Res_Value[7] := 0;
NextIfd := 0;
GetDIBSizes(Bitmap.Handle, HeaderSize, BitsSize);
Header := GlobalAllocPtr(GMEM_MOVEABLE or GMEM_SHARE, HeaderSize + BitsSize);
try
Bits := Header + HeaderSize;
dib_f := GetDIB(Bitmap.Handle, Bitmap.Palette, Header^, Bits^);
if dib_f then
begin
Width := PBITMAPINFO(Header)^.bmiHeader.biWidth;
Height := PBITMAPINFO(Header)^.bmiHeader.biHeight;
BitCount := PBITMAPINFO(Header)^.bmiHeader.biBitCount;
NoOfDirs[0] := $0F;
ColTabSize := 1 shl BitCount;
BmpWidth := BitsSize div DWORD(Height);
if not WriteHeader then
NextIfd := Stream.Size - 4
else
begin
Stream.Write(TifHeader, sizeof(TifHeader));
NextIfd := 4;
end;
if BitCount = 1 then
begin
CopyMemory(@D_BW, @D_BW_C, SizeOf(D_BW));
NoOfDirs[0] := $0E;
O_XRes := Stream.Position;
Stream.Write(Res_Value, sizeof(Res_Value));
O_YRes := Stream.Position;
Stream.Write(Res_Value, sizeof(Res_Value));
O_Soft := Stream.Position;
Stream.Write(Software, sizeof(Software));
DataWidth := ((Width + 7) div 8);
O_Strip := Stream.Position;
if Height < 0 then
for i := 0 to Height - 1 do
begin
BitsPtr := Bits + i * BmpWidth;
Stream.Write(BitsPtr^, DataWidth);
end
else
for i := 1 to Height do
begin
BitsPtr := Bits + (Height - i) * BmpWidth;
Stream.Write(BitsPtr^, DataWidth);
end;
Stream.Write(NullString, sizeof(NullString));
D_BW[1]._Value := LongInt(Width);
D_BW[2]._Value := LongInt(abs(Height));
D_BW[8]._Value := LongInt(abs(Height));
D_BW[9]._Value := LongInt(DataWidth * abs(Height));
D_BW[6]._Value := O_Strip;
D_BW[10]._Value := O_XRes;
D_BW[11]._Value := O_YRes;
D_BW[13]._Value := O_Soft;
O_Dir := Stream.Position;
Stream.Write(NoOfDirs, sizeof(NoOfDirs));
Stream.Write(D_BW, sizeof(D_BW));
Stream.Write(NullString, sizeof(NullString));
end;
if BitCount in [4, 8] then
begin
CopyMemory(@D_COL, @D_COL_C, SizeOf(D_COL));
DataWidth := Width;
if BitCount = 4 then
begin
Width := (Width div BitCount) * BitCount;
if BitCount = 4 then
DataWidth := Width div 2;
end;
D_COL[1]._Value := LongInt(Width);
D_COL[2]._Value := LongInt(abs(Height));
D_COL[3]._Value := LongInt(BitCount);
D_COL[8]._Value := LongInt(Height);
D_COL[9]._Value := LongInt(DataWidth * abs(Height));
for i := 0 to ColTabSize - 1 do
begin
MapRed[i][1] := PBITMAPINFO(Header)^.bmiColors[i].rgbRed;
MapRed[i][0] := 0;
MapGreen[i][1] := PBITMAPINFO(Header)^.bmiColors[i].rgbGreen;
MapGreen[i][0] := 0;
MapBlue[i][1] := PBITMAPINFO(Header)^.bmiColors[i].rgbBlue;
MapBlue[i][0] := 0;
end;
D_COL[14]._Count := LongInt(ColTabSize * 3);
Stream.Write(MapRed, ColTabSize * 2);
Stream.Write(MapGreen, ColTabSize * 2);
Stream.Write(MapBlue, ColTabSize * 2);
O_XRes := Stream.Position;
Stream.Write(Res_Value, sizeof(Res_Value));
O_YRes := Stream.Position;
Stream.Write(Res_Value, sizeof(Res_Value));
O_Soft := Stream.Position;
Stream.Write(Software, sizeof(Software));
O_Strip := Stream.Position;
if Height < 0 then
for i := 0 to Height - 1 do
begin
BitsPtr := Bits + i * BmpWidth;
Stream.Write(BitsPtr^, DataWidth);
end
else
for i := 1 to Height do
begin
BitsPtr := Bits + (Height - i) * BmpWidth;
Stream.Write(BitsPtr^, DataWidth);
end;
D_COL[6]._Value := O_Strip;
D_COL[10]._Value := O_XRes;
D_COL[11]._Value := O_YRes;
D_COL[13]._Value := O_Soft;
O_Dir := Stream.Position;
Stream.Write(NoOfDirs, sizeof(NoOfDirs));
Stream.Write(D_COL, sizeof(D_COL));
Stream.Write(NullString, sizeof(NullString));
end;
if BitCount = 16 then
begin
CopyMemory(@D_RGB, @D_RGB_C, SizeOf(D_RGB));
D_RGB[1]._Value := LongInt(Width);
D_RGB[2]._Value := LongInt(Height);
D_RGB[8]._Value := LongInt(Height);
D_RGB[9]._Value := LongInt(3 * Width * Height);
O_XRes := Stream.Position;
Stream.Write(Res_Value, sizeof(Res_Value));
O_YRes := Stream.Position;
Stream.Write(Res_Value, sizeof(Res_Value));
O_BPS := Stream.Position;
Stream.Write(BitsPerSample, sizeof(BitsPerSample));
O_Soft := Stream.Position;
Stream.Write(Software, sizeof(Software));
O_Strip := Stream.Position;
GetMem(NewBits, Width * Height * 3);
for i := 0 to Height - 1 do
begin
BitsPtr := Bits + i * BmpWidth;
TmpBitsPtr := NewBits + i * Width * 3;
for k := 0 to Width - 1 do
begin
RGB := PWord(BitsPtr)^;
Blue := AnsiChar((RGB and $1F) shl 3 or $7);
Green := AnsiChar((RGB shr 5 and $1F) shl 3 or $7);
Red := AnsiChar((RGB shr 10 and $1F) shl 3 or $7);
PByte(TmpBitsPtr)^ := Byte(Red);
PByte(TmpBitsPtr + 1)^ := Byte(Green);
PByte(TmpBitsPtr + 2)^ := Byte(Blue);
BitsPtr := BitsPtr + 2;
TmpBitsPtr := TmpBitsPtr + 3;
end;
end;
for i := 1 to Height do
begin
TmpBitsPtr := NewBits + (Height - i) * Width * 3;
Stream.Write(TmpBitsPtr^, Width * 3);
end;
FreeMem(NewBits);
D_RGB[3]._Value := O_BPS;
D_RGB[6]._Value := O_Strip;
D_RGB[10]._Value := O_XRes;
D_RGB[11]._Value := O_YRes;
D_RGB[14]._Value := O_Soft;
O_Dir := Stream.Position;
Stream.Write(NoOfDirs, sizeof(NoOfDirs));
Stream.Write(D_RGB, sizeof(D_RGB));
Stream.Write(NullString, sizeof(NullString));
end;
if BitCount in [24, 32] then
begin
CopyMemory(@D_RGB, @D_RGB_C, SizeOf(D_RGB));
D_RGB[1]._Value := LongInt(Width);
D_RGB[2]._Value := LongInt(Height);
D_RGB[8]._Value := LongInt(Height);
D_RGB[9]._Value := LongInt(3 * Width * Height);
O_XRes := Stream.Position;
Stream.Write(Res_Value, sizeof(Res_Value));
O_YRes := Stream.Position;
Stream.Write(Res_Value, sizeof(Res_Value));
O_BPS := Stream.Position;
Stream.Write(BitsPerSample, sizeof(BitsPerSample));
O_Soft := Stream.Position;
Stream.Write(Software, sizeof(Software));
O_Strip := Stream.Position;
for i := 0 to Height - 1 do
begin
BitsPtr := Bits + i * BmpWidth;
for k := 0 to Width - 1 do
begin
Blue := (BitsPtr)^;
Red := (BitsPtr + 2)^;
(BitsPtr)^ := Red;
(BitsPtr + 2)^ := Blue;
BitsPtr := BitsPtr + BitCount div 8;
end;
end;
if BitCount = 32 then
for i := 0 to Height - 1 do
begin
BitsPtr := Bits + i * BmpWidth;
TmpBitsPtr := BitsPtr;
for k := 0 to Width - 1 do
begin
(TmpBitsPtr)^ := (BitsPtr)^;
(TmpBitsPtr + 1)^ := (BitsPtr + 1)^;
(TmpBitsPtr + 2)^ := (BitsPtr + 2)^;
TmpBitsPtr := TmpBitsPtr + 3;
BitsPtr := BitsPtr + 4;
end;
end;
BmpWidth := Trunc(BitsSize / Height);
if Height < 0 then
for i := 0 to Height - 1 do
begin
BitsPtr := Bits + i * BmpWidth;
Stream.Write(BitsPtr^, Width * 3);
end
else
for i := 1 to Height do
begin
BitsPtr := Bits + (Height - i) * BmpWidth;
Stream.Write(BitsPtr^, Width * 3);
end;
D_RGB[3]._Value := O_BPS;
D_RGB[6]._Value := O_Strip;
D_RGB[10]._Value := O_XRes;
D_RGB[11]._Value := O_YRes;
D_RGB[14]._Value := O_Soft;
O_Dir := Stream.Position;
Stream.Write(NoOfDirs, sizeof(NoOfDirs));
Stream.Write(D_RGB, sizeof(D_RGB));
Stream.Write(NullString, sizeof(NullString));
end;
end;
finally
GlobalFreePtr(Header);
end;
Stream.Seek(NextIfd, soFromBeginning);
Stream.Write(O_Dir, 4);
Stream.Seek(0, soFromEnd);
end;
function TfrxTIFFExport.Start: Boolean;
begin
FMultiImage := FMultiImage and not FSeparate;
if not FMultiImage then
begin
Result := inherited Start;
Exit;
end;
CurPage := False;
FCurrentPage := 0;
FYOffset := 0;
Result := (FileName <> '') or (Stream <> nil);
try
if Stream = nil then
begin
// Stream := TFileStream.Create(ChangeFileExt(FileName, FFileSuffix + '.tif'), fmCreate);
Stream := IOTransport.GetStream(ChangeFileExt(FileName, FFileSuffix + DefaultExt));
FIsStreamCreated := True;
end;
FFirstPage := True;
except
on e: Exception do
case Report.EngineOptions.NewSilentMode of
simSilent: Report.Errors.Add(e.Message);
simMessageBoxes: frxErrorMsg(e.Message);
simReThrow: raise;
end;
end;
end;
procedure TfrxTIFFExport.StartPage(Page: TfrxReportPage; Index: Integer);
begin
if not FMultiImage then
begin
inherited;
Exit;
end;
Inc(FCurrentPage);
FBitmap := TBitmap.Create;
FBitmap.Canvas.Lock;
try
FBitmap.Canvas.Brush.Color := clWhite;
FCurrentRes := FBitmap.Canvas.Font.PixelsPerInch;
FDiv := FResolution / FCurrentRes;
finally
FBitmap.Canvas.Unlock
end;
FBitmap.Monochrome := Monochrome;
FBitmap.Width := Round(Page.Width * FDiv);
FBitmap.Height := Round(Page.Height * FDiv);
FMaxX := 0;
FMaxY := 0;
FMinX := FBitmap.Width;
FMinY := FBitmap.Height;
end;
{$ENDIF}
{ TfrxJPEGExport }
constructor TfrxJPEGExport.Create(AOwner: TComponent);
begin
inherited;
FPicFormatName := 'JPG';
FilterDesc := frxResources.Get('JPEGexportFilter');
DefaultExt := '.jpg';
end;
class function TfrxJPEGExport.GetDescription: String;
begin
Result := frxResources.Get('JPEGexport');
end;
{ TfrxGIFExport }
{$IFNDEF FPC}
procedure GIFSaveToFile(const FileName: String; const Bitmap: TBitmap);
var
f: TFileStream;
begin
f := TFileStream.Create(FileName, fmCreate);
try
GIFSaveToStream(f, Bitmap);
finally
f.Free;
end;
end;
constructor TfrxGIFExport.Create(AOwner: TComponent);
begin
inherited;
FilterDesc := frxResources.Get('GifexportFilter');
DefaultExt := '.gif';
end;
class function TfrxGIFExport.GetDescription: String;
begin
Result := frxResources.Get('GIFexport');
end;
procedure TfrxGIFExport.SaveToStream(const aStream: TStream);
begin
try
GIFSaveToStream(aStream, FBitmap)
except
on e: Exception do
case Report.EngineOptions.NewSilentMode of
simSilent:
Report.Errors.Add(e.Message);
simMessageBoxes:
frxErrorMsg(e.Message);
simReThrow:
raise;
end;
end;
end;
{ TfrxEMFExport }
constructor TfrxEMFExport.Create(AOwner: TComponent);
begin
inherited;
FPicFormatName := 'EMF';
FilterDesc := frxResources.Get('EMFexportFilter');
DefaultExt := '.emf';
end;
class function TfrxEMFExport.GetDescription: String;
begin
Result := frxResources.Get('EMFexport')
end;
procedure TfrxEMFExport.ExportObject(Obj: TfrxComponent);
var
z: Integer;
begin
if (Obj is TfrxView) and (FExportNotPrintable or TfrxView(Obj).Printable) then
begin
if not IsPageBG(Obj) then
begin
z := Round(Obj.AbsLeft * FDiv);
if z < FMinX then
FMinX := z;
z := FYOffset + Round(Obj.AbsTop * FDiv);
if z < FMinY then
FMinY := z;
z := Round((Obj.AbsLeft + Obj.Width) * FDiv) + 1;
if z > FMaxX then
FMaxX := z;
z := FYOffset + Round((Obj.AbsTop + Obj.Height) * FDiv) + 1;
if z > FMaxY then
FMaxY := z;
end;
TfrxView(Obj).Draw(FMetafileCanvas, FDiv, FDiv, 0, FYOffset);
end;
end;
procedure TfrxEMFExport.FinishExport;
var
RFrom, RTo: TRect;
begin
try
if FCrop then
begin
RFrom := Rect(FMinX, FMinY, FMaxX, FMaxY);
RTo := Rect(0, 0, FMaxX - FMinX, FMaxY - FMinY);
FMetafileCanvas.CopyRect(RTo, FMetafileCanvas, RFrom);
FMetafile.Width := FMaxX - FMinX;
FMetafile.Height := FMaxY - FMinY;
end;
Save;
finally
FMetafile.Free;
end;
end;
procedure TfrxEMFExport.SaveToStream(const aStream: TStream);
begin
FreeAndNil(FMetafileCanvas);
FMetafile.SaveToStream(aStream);
end;
function TfrxEMFExport.Start: Boolean;
begin
CurPage := False;
FCurrentPage := 0;
FYOffset := 0;
if not FSeparate then
begin
FMetafile := TMetafile.Create;
FMetafileCanvas := TMetafileCanvas.Create(FMetafile, 0);
FDiv := EMF_DIV;
FMetafileCanvas.Brush.Color := clWhite;
FMaxX := 0;
FMaxY := 0;
FFirstPage := True;
end;
Result := (FileName <> '') or (Stream <> nil);
end;
procedure TfrxEMFExport.StartPage(Page: TfrxReportPage; Index: Integer);
var
i: Extended;
begin
Inc(FCurrentPage);
if FSeparate then
begin
FMetafile := TMetafile.Create;
FDiv := EMF_DIV;
FMetafile.Width := Round(Page.Width * FDiv);
FMetafile.Height := Round(Page.Height * FDiv);
FMetafileCanvas := TMetafileCanvas.Create(FMetafile, 0);
FMetafileCanvas.Brush.Color := clWhite;
FMaxX := 0;
FMaxY := 0;
FMinX := FMetafile.Width;
FMinY := FMetafile.Height;
end else
begin
if FFirstpage then
begin
if FMetafile.Width < Round(Page.Width * FDiv) then
FMetafile.Width := Round(Page.Width * FDiv);
i := Page.Height * Report.PreviewPages.Count * FDiv;
if SizeOverflow(i) then
i := MaxBitmapHeight;
FMetafile.Height := Round(i);
FFirstPage := False;
FMinX := FMetafile.Width;
FMinY := FMetafile.Height;
end;
end;
end;
{$ENDIF}
{ TfrxPNGExport }
constructor TfrxPNGExport.Create(AOwner: TComponent);
begin
inherited;
DefaultExt := '.png';
FPicFormatName := 'PNG';
FilterDesc := frxResources.Get('PNGexportFilter')
end;
class function TfrxPNGExport.GetDescription: String;
begin
Result := frxResources.Get('PNGexport')
end;
end.
Reference in New Issue Copy Permalink