{******************************************}
{                                          }
{             FastReport v4.0              }
{          Picture Export Filters          }
{                                          }
{         Copyright (c) 1998-2011          }
{          by Alexander Fediachov,         }
{             Fast Reports Inc.            }
{                                          }
{******************************************}

unit FMX.frxExportImage;

interface

{$I frx.inc}
{$I fmx.inc}

uses
  System.SysUtils, System.Classes, FMX.Controls, FMX.Forms, FMX.Dialogs,
  FMX.frxClass, FMX.Edit, FMX.Types, System.UITypes, System.Types,
  System.UIConsts, System.Variants, FMX.frxBaseModalForm
{$IFDEF DELPHI18}
  , FMX.StdCtrls
  , FMX.Surfaces
{$ENDIF}
{$IFDEF DELPHI19}
  , FMX.Graphics
{$ENDIF}
{$IFDEF DELPHI28}
  , FMX.BaseTypeAliases, FMX.FormTypeAliases
{$ENDIF};


type
  TfrxCustomImageExport = class(TfrxCustomExportFilter)
  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;
    procedure Save; virtual;
    procedure FinishExport; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    function ShowModal: TModalResult; 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;

    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;


{$I frxFMX_PlatformsAttribute.inc}
  TfrxBMPExport = class(TfrxCustomImageExport)
  protected
    procedure Save; override;
  public
    constructor Create(AOwner: TComponent); override;
    class function GetDescription: String; override;
  published
    property CropImages;
    property Monochrome;
    property OverwritePrompt;
  end;


{$I frxFMX_PlatformsAttribute.inc}
  TfrxTIFFExport = class(TfrxCustomImageExport)
  private
    FMultiImage: 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);}

  protected
    procedure Save; override;
  public
    constructor Create(AOwner: TComponent); override;
    class function GetDescription: String; override;
  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. }

    property MultiImage: Boolean read FMultiImage write FMultiImage default False;
  end;


{$I frxFMX_PlatformsAttribute.inc}
  TfrxJPEGExport = class(TfrxCustomImageExport)
  protected
    procedure Save; override;
  public
    constructor Create(AOwner: TComponent); override;
    class function GetDescription: String; override;
  published
    property JPEGQuality;
    property CropImages;
    property Monochrome;
    property OverwritePrompt;
  end;

{$I frxFMX_PlatformsAttribute.inc}
  TfrxGIFExport = class(TfrxCustomImageExport)
  protected
    procedure Save; override;
  public
    constructor Create(AOwner: TComponent); override;
    class function GetDescription: String; override;
  published
    property CropImages;
    property Monochrome;
    property OverwritePrompt;
  end;

{$I frxFMX_PlatformsAttribute.inc}
  TfrxPNGExport = class(TfrxCustomImageExport)
  protected
    procedure Save; override;
  public
    constructor Create(AOwner: TComponent); override;
    class function GetDescription: String; override;
  published
    property CropImages;
    property Monochrome;
    property OverwritePrompt;
  end;

  TfrxIMGExportDialog = class(TfrxForm)
    OK: TButton;
    Cancel: TButton;
    GroupPageRange: TGroupBox;
    GroupBox1: TGroupBox;
    CropPage: TCheckBox;
    Label2: TLabel;
    Quality: TEdit;
    Mono: TCheckBox;
    SaveDialog1: TSaveDialog;
    DescrL: TLabel;
    AllRB: TRadioButton;
    CurPageRB: TRadioButton;
    PageNumbersRB: TRadioButton;
    PageNumbersE: TEdit;
    Label1: TLabel;
    Resolution: TEdit;
    SeparateCB: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure PageNumbersEChange(Sender: TObject);
    procedure PageNumbersEKeyPress(Sender: TObject; var Key: Word;
      var KeyChar: WideChar; Shift: TShiftState);
  private
    FFilter: TfrxCustomImageExport;
    procedure SetFilter(const Value: TfrxCustomImageExport);
  public
    property Filter: TfrxCustomImageExport read FFilter write SetFilter;
  end;

implementation

uses
  FMX.frxUtils, FMX.frxRes, FMX.frxrcExports;

{$R *.fmx}

type
  PDirEntry = ^TDirEntry;
  TDirEntry = record
    _Tag: Word;
    _Type: Word;
    _Count: LongInt;
    _Value: LongInt;
  end;

const
  EMF_DIV = 0.911;
  TifHeader: array[0..7] of Byte = (
    $49, $49, $2A, $00, $08, $00, $00, $00);

  { 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;

  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));


procedure SaveImage(Stream: TStream; Bitmap: TBitmap; FileName: String; FFileSuffix: String; Format: String);
{$IFNDEF Delphi18}
{$IFNDEF Delphi17}
var
  TFStream: TStream;
  Filter: TBitmapCodec;
begin
  if Stream = nil then
    TFStream := TFileStream.Create(ChangeFileExt(FileName, FFileSuffix + '.' + Format), fmCreate)
  else
    TFStream := Stream;
  try
    Filter := DefaultBitmapCodecClass.Create;
    try
      Filter.SaveToStream(TFStream, Bitmap, Format);
    finally
      Filter.Free
    end;
  finally
    if Stream = nil then
      TFStream.Free
  end;
{$ELSE}
var
  TFStream: TStream;
begin
  if Stream = nil then
    TFStream := TFileStream.Create(ChangeFileExt(FileName, FFileSuffix + '.' + Format), fmCreate)
  else
    TFStream := Stream;
  try
      TBitmapCodecManager.SaveToStream(TFStream, Bitmap, Format);
  finally
    if Stream = nil then
      TFStream.Free
  end;
{$ENDIF}
{$ELSE}
var
  TFStream: TStream;
  Surf: TBitmapSurface;
begin
  if Stream = nil then
    TFStream := TFileStream.Create(ChangeFileExt(FileName, FFileSuffix + '.' + Format), fmCreate)
  else
    TFStream := Stream;
  Surf := TBitmapSurface.Create;
  Surf.Assign(Bitmap);
  try
      TBitmapCodecManager.SaveToStream(TFStream, Surf, Format);
  finally
    if Stream = nil then
      TFStream.Free;
    Surf.Free;
  end;
{$ENDIF}
end;

{ TfrxCustomImageExport }

constructor TfrxCustomImageExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCrop := True;
  FJPEGQuality := 90;
  FResolution := 96;
  FSeparate := True;
  FExportNotPrintable := False;
  CropImages := False;
end;

function TfrxCustomImageExport.ShowModal: TModalResult;
begin
  with TfrxIMGExportDialog.Create(nil) do
  begin
    Filter := Self;
    Quality.Text := IntToStr(FJPEGQuality);
    CropPage.IsChecked := FCrop;
    Mono.IsChecked := FMonochrome;
    Quality.Enabled := Self is TfrxJPEGExport;
    Mono.Enabled := not (Self is TfrxGIFExport);
    Resolution.Text := IntToStr(FResolution);
    if OverwritePrompt then
      SaveDialog1.Options := SaveDialog1.Options + [TOpenOption.ofOverwritePrompt];
    if SlaveExport then
    begin
      SeparateCB.IsChecked := False;
      SeparateCB.Visible := False;
    end
    else
      SeparateCB.IsChecked := FSeparate;

    if (FileName = '') and (not SlaveExport) then
      SaveDialog1.FileName := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(Report.FileName)), SaveDialog1.DefaultExt)
    else
      SaveDialog1.FileName := FileName;

    if PageNumbers <> '' then
    begin
      PageNumbersE.Text := PageNumbers;
      PageNumbersRB.IsChecked := True;
    end;

    Result := ShowModal;
    PeekLastModalResult;
    if Result = mrOk then
    begin
      FJPEGQuality := StrToInt(Quality.Text);
      FCrop := CropPage.IsChecked;
      FMonochrome := Mono.IsChecked;
      FResolution := StrToInt(Resolution.Text);
      FSeparate := SeparateCB.IsChecked;
      PageNumbers := '';
      CurPage := False;
      if CurPageRB.IsChecked then
        CurPage := True
      else if PageNumbersRB.IsChecked then
        PageNumbers := PageNumbersE.Text;

      if not SlaveExport then
      begin
        if DefaultPath <> '' then
          SaveDialog1.InitialDir := DefaultPath;
        if SaveDialog1.Execute then
          FileName := SaveDialog1.FileName else
          Result := mrCancel;
        PeekLastModalResult;
      end;
    end;
    Free;
  end;
end;

function TfrxCustomImageExport.Start: Boolean;
begin
  if SlaveExport then
  begin
    if Report.FileName <> '' then
      FileName := ChangeFileExt(GetTemporaryFolder + ExtractFileName(Report.FileName), DefaultExt)
    else
      FileName := ChangeFileExt(GetTempFile, DefaultExt);
    FSeparate := False;
  end;
  CurPage := False;
  FCurrentPage := 0;
  FYOffset := 0;
  if not FSeparate then
  begin
    FBitmap := TBitmap.Create(0,0);
    FCurrentRes := 96;// FBitmap.r;
    FDiv := FResolution / FCurrentRes;
    FBitmap.Canvas.Fill.Kind := TBrushKind.bkSolid;
    FBitmap.Canvas.Fill.Color := claWhite;
    //FBitmap.Canvas.Clear(claWhite);
    //FBitmap.Monochrome := Monochrome;
    FMaxX := 0;
    FMaxY := 0;
    FFirstPage := True;
  end;
  Result := (FileName <> '') or (Stream <> nil);
  if (ExtractFilePath(FileName) = '') and (DefaultPath <> '') then
    FileName := DefaultPath + '\' + FileName;
end;

procedure TfrxCustomImageExport.StartPage(Page: TfrxReportPage; Index: Integer);
var
  i: Integer;
  h, w: Extended;
begin
  Inc(FCurrentPage);
  if FSeparate then
  begin

    FCurrentRes := 96;// FBitmap.Canvas.Font.PixelsPerInch;
    FDiv := FResolution / FCurrentRes;
    //FBitmap.Canvas.Brush.Color := clWhite;
    //FBitmap.Monochrome := Monochrome;
    FBitmap := TBitmap.Create(Round(Page.Width * FDiv), Round(Page.Height * FDiv));
    //FBitmap.UpdateHandles;
    FBitmap.Canvas.Fill.Kind := TBrushKind.bkSolid;
    FBitmap.Canvas.Fill.Color := claWhite;
    FBitmap.Canvas.BeginScene();
    FBitmap.Canvas.Clear(claWhite);

    FMaxX := 0;
    FMaxY := 0;
    FMinX := FBitmap.Width;
    FMinY := FBitmap.Height;
  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;

      FFirstPage := False;
      Canvas.BeginScene();
      Canvas.Clear(claWhite);
    end;
end;

procedure TfrxCustomImageExport.ExportObject(Obj: TfrxComponent);
var
  z: Integer;
begin
  if (Obj is TfrxView) and (FExportNotPrintable or TfrxView(Obj).Printable) then
  begin
    if Obj.Name <> '_pagebackground' 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(FBitmap.Canvas, FDiv, FDiv, 0, FYOffset);
  end;
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;
end;

procedure TfrxCustomImageExport.Save;
begin
  if FSeparate then
    FFileSuffix := '.' + IntToStr(FCurrentPage)
  else
    FFileSuffix := '';
end;

procedure TfrxCustomImageExport.FinishExport;
var
  RFrom, RTo: TRectF;
  TempBitmap: TBitmap;
begin
  try
    FBitmap.Canvas.EndScene;
    if FCrop then
    begin
      RFrom := RectF(FMinX, FMinY, FMaxX, FMaxY);
      RTo := RectF(0, 0, FMaxX - FMinX, FMaxY - FMinY);
      TempBitmap := TBitmap.Create(FBitmap.Width, FBitmap.Height);
      TempBitmap.Canvas.BeginScene();
{$IFDEF DELPHI18}
      TempBitmap.Canvas.CopyBitmap(FBitmap, TempBitmap);
{$ELSE}
      TempBitmap.Canvas.DrawBitmap(FBitmap, RectF(0, 0, FBitmap.Width, FBitmap.Height), RectF(0, 0, FBitmap.Width, FBitmap.Height), 1, False);
{$ENDIF}
      TempBitmap.Canvas.EndScene;
      FBitmap.Width := FMaxX - FMinX;
      FBitmap.Height := FMaxY - FMinY;
      FBitmap.Canvas.BeginScene();
      FBitmap.Canvas.DrawBitmap(TempBitmap, RFrom, RTo, 1, False);
      TempBitmap.Free;
      FBitmap.Canvas.EndScene;
    end;
    Save;
  finally
    FBitmap.Free;
  end;
end;

function TfrxCustomImageExport.SizeOverflow(const Val: Extended): Boolean;
begin
  Result :=  Val > MaxBitmapHeight;
end;

{ TfrxIMGExportDialog }

procedure TfrxIMGExportDialog.FormCreate(Sender: TObject);
begin
  Caption := frxGet(8600);
  OK.Text := frxGet(1);
  Cancel.Text := frxGet(2);
  GroupPageRange.Text := frxGet(7);
  AllRB.Text := frxGet(3);
  CurPageRB.Text := frxGet(4);
  PageNumbersRB.Text := frxGet(5);
  DescrL.Text := frxGet(9);
  GroupBox1.Text := frxGet(8601);
  Label2.Text := frxGet(8602);
  Label1.Text := frxGet(8603);
  SeparateCB.Text := frxGet(8604);
  CropPage.Text := frxGet(8605);
  Mono.Text := frxGet(8606);
{$IFDEF LINUX}
  BorderStyleSizeable(Self);
{$ENDIF}
  //if UseRightToLeftAlignment then
  //  FlipChildren(True);
end;

procedure TfrxIMGExportDialog.SetFilter(const Value: TfrxCustomImageExport);
begin
  FFilter := Value;
  SaveDialog1.Filter := FFilter.FilterDesc;
  SaveDialog1.DefaultExt := FFilter.DefaultExt;
end;


{ TfrxBMPExport }

constructor TfrxBMPExport.Create(AOwner: TComponent);
begin
  inherited;
  FilterDesc := frxResources.Get('BMPexportFilter');
  DefaultExt := '.bmp';
end;

class function TfrxBMPExport.GetDescription: String;
begin
  Result := frxResources.Get('BMPexport');
end;

procedure TfrxBMPExport.Save;
begin
  inherited;
  SaveImage(Stream, FBitmap, FileName, FFileSuffix, 'bmp');
end;


{ TfrxTIFFExport }

constructor TfrxTIFFExport.Create(AOwner: TComponent);
begin
  inherited;
  FilterDesc := frxResources.Get('TIFFexportFilter');
  DefaultExt := '.tif';
end;

class function TfrxTIFFExport.GetDescription: String;
begin
  Result := frxResources.Get('TIFFexport');
end;

procedure TfrxTIFFExport.Save;
begin
  inherited;
  try
    SaveImage(Stream, FBitmap, FileName, FFileSuffix, 'tif');
  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.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 }
 {
  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
        begin
          Left := x;
          Top := y;
          Right := Min(x + Width, Bitmap.Width) - 1;
          Bottom := Min(y + Height, Bitmap.Height) - 1;
        end;

        with Dest do
        begin
          Left := 0;
          Top := 0;
          Right := Source.Right - Source.Left;
          Bottom := Source.Bottom - Source.Top;
        end;

        Page := TBitmap.Create;

        with Page do
        begin
          Canvas.Fill.Color := claWhite;
          Monochrome := Monochrome;
          Width := Dest.Right + 1;
          Height := Dest.Bottom + 1;
          Canvas.DrawBitmap(Bitmap, Source, Dest, 1, False );
        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;
  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; }

{ TfrxJPEGExport }

constructor TfrxJPEGExport.Create(AOwner: TComponent);
begin
  inherited;
  FilterDesc := frxResources.Get('JPEGexportFilter');
  DefaultExt := '.jpg';
end;

class function TfrxJPEGExport.GetDescription: String;
begin
  Result := frxResources.Get('JPEGexport');
end;

procedure TfrxJPEGExport.Save;
begin
  inherited;
  try
    SaveImage(Stream, FBitmap, FileName, FFileSuffix, 'jpeg');
  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;

{ TfrxGIFExport }

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.Save;
begin
  inherited;
  try
     SaveImage(Stream, FBitmap, FileName, FFileSuffix, 'gif');
  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 TfrxIMGExportDialog.PageNumbersEChange(Sender: TObject);
begin
  PageNumbersRB.IsChecked := True;
end;

procedure TfrxIMGExportDialog.PageNumbersEKeyPress(Sender: TObject; var Key: Word;
      var KeyChar: WideChar; Shift: TShiftState);
begin
  case Char(key) of
    '0'..'9':;
    #8, '-', ',':;
  else
    key := 0;
  end;
end;


{ TfrxPNGExport }

constructor TfrxPNGExport.Create(AOwner: TComponent);
begin
  inherited;
  DefaultExt := '.png';
  FilterDesc := frxResources.Get('PNGexportFilter')
end;

class function TfrxPNGExport.GetDescription: String;
begin
  Result := frxResources.Get('PNGexport')
end;

procedure TfrxPNGExport.Save;
begin
  inherited;
  SaveImage(Stream, FBitmap, FileName, FFileSuffix, 'png');
end;

end.