frxexportimage.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

{******************************************}
{                                          }
{             FastReport v3.0              }
{     BMP, JPEG, TIFF export filters       }
{                                          }
{         Copyright (c) 1998-2005          }
{          by Alexander Fediachov,         }
{             Fast Reports Inc.            }
{                                          }
{******************************************}

unit frxExportImage;

interface

{$I frx.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, frxClass, Jpeg
{$IFDEF Delphi6}
, Variants
{$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
    FDiv: Extended;
    procedure Save; virtual;
    procedure FinishExport;
  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 True;
    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;
  end;

  TfrxBMPExport = class(TfrxCustomImageExport)
  protected
    procedure Save; override;
  public
    class function GetDescription: String; override;
  published
    property CropImages;
    property Monochrome;
  end;

  TfrxTIFFExport = class(TfrxCustomImageExport)
  private
    procedure SaveTiffToStream(Stream: TStream; Bitmap: TBitmap);
  protected
    procedure Save; override;
  public
    class function GetDescription: String; override;
  published
    property CropImages;
    property Monochrome;
  end;

  TfrxJPEGExport = class(TfrxCustomImageExport)
  protected
    procedure Save; override;
  public
    class function GetDescription: String; override;
  published
    property JPEGQuality;
    property CropImages;
    property Monochrome;
  end;

  TfrxIMGExportDialog = class(TForm)
    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);
  private
    FFilter: TfrxCustomImageExport;
    procedure SetFilter(const Value: TfrxCustomImageExport);
  public
    property Filter: TfrxCustomImageExport read FFilter write SetFilter;
  end;


implementation

uses frxUtils, frxRes, frxrcExports;

{$R *.dfm}

const
  TifHeader: array[0..7] of Byte = (
    $49, $49, $2A, $00, $08, $00, $00, $00);
  NoOfDirs: array[0..1] of Byte = ($0F, $00);
  MAX_TBITMAP_HEIGHT = 30000;

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

var
  D_BW: 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: 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: 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));

  NullString: array[0..3] of Byte = ($00, $00, $00, $00);
  Res_Value: array[0..7] of Byte = ($c3, $03, $00, $00, $0A, $00, $00, $00);
  Software: array[0..9] of Char = ('F', 'a', 's', 't', 'R', 'e', 'p', 'o', 'r', 't');
  BitsPerSample: array[0..2] of Word = ($0008, $0008, $0008);


{ TfrxCustomImageExport }

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

function TfrxCustomImageExport.ShowModal: TModalResult;
begin
  with TfrxIMGExportDialog.Create(nil) do
  begin
    Filter := Self;
    Quality.Text := IntToStr(FJPEGQuality);
    CropPage.Checked := FCrop;
    Mono.Checked := FMonochrome;
    Quality.Enabled := Self is TfrxJPEGExport;
    Resolution.Text := IntToStr(FResolution);
    SeparateCB.Checked := FSeparate;
    Result := ShowModal;
    if Result = mrOk then
    begin
      FJPEGQuality := StrToInt(Quality.Text);
      FCrop := CropPage.Checked;
      FMonochrome := Mono.Checked;
      FResolution := StrToInt(Resolution.Text);
      FSeparate := SeparateCB.Checked;
      PageNumbers := '';
      CurPage := False;
      if CurPageRB.Checked then
        CurPage := True
      else if PageNumbersRB.Checked then
        PageNumbers := PageNumbersE.Text;

      if SaveDialog1.Execute then
        FileName := SaveDialog1.FileName else
        Result := mrCancel;
    end;
    Free;
  end;
end;

function TfrxCustomImageExport.Start: Boolean;
begin
  CurPage := False;
  FCurrentPage := 0;
  FYOffset := 0;
  if not FSeparate then
  begin
    FBitmap := TBitmap.Create;
    FCurrentRes := FBitmap.Canvas.Font.PixelsPerInch;
    FDiv := FResolution / FCurrentRes;
    FBitmap.Canvas.Brush.Color := clWhite;
    FBitmap.Monochrome := Monochrome;
    FMaxX := 0;
    FMaxY := 0;
    FFirstPage := True;
  end;
  Result := FileName <> '';
end;

procedure TfrxCustomImageExport.StartPage(Page: TfrxReportPage; Index: Integer);
var
  i: Extended;
begin
  Inc(FCurrentPage);
  if FSeparate then
  begin
    FBitmap := TBitmap.Create;
    FCurrentRes := FBitmap.Canvas.Font.PixelsPerInch;
    FDiv := FResolution / FCurrentRes;
    FBitmap.Canvas.Brush.Color := clWhite;
    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 else
  begin
    if FFirstpage then
    begin
      if FBitmap.Width < Round(Page.Width * FDiv) then
        FBitmap.Width := Round(Page.Width * FDiv);
      i := Page.Height * Report.PreviewPages.Count * FDiv;
      if SizeOverflow(i) then
        i := MAX_TBITMAP_HEIGHT;
      FBitmap.Height := Round(i);
      FFirstPage := False;
    end;
    FMinX := FBitmap.Width;
    FMinY := FBitmap.Height;
  end;
end;

procedure TfrxCustomImageExport.ExportObject(Obj: TfrxComponent);
begin
  if (Obj is TfrxView) and (FExportNotPrintable or TfrxView(Obj).Printable) then
  begin
    if Round(Obj.AbsLeft * FDiv) < FMinX then
      FMinX := Round(Obj.AbsLeft * FDiv);
    if (FYOffset + Round(Obj.AbsTop * FDiv)) < FMinY then
      FMinY := FYOffset + Round(Obj.AbsTop * FDiv);
    if ((Obj.AbsLeft + Obj.Width) * FDiv) > FMaxX then
      FMaxX := Round((Obj.AbsLeft + Obj.Width) * FDiv) + 1;
    if (FYOffset + ((Obj.AbsTop + Obj.Height) * FDiv)) > FMaxY then
      FMaxY := FYOffset + Round((Obj.AbsTop + Obj.Height) * FDiv) + 1;
    TfrxView(Obj).Draw(FBitmap.Canvas, FDiv, FDiv, 0, FYOffset);
  end;
end;

procedure TfrxCustomImageExport.FinishPage(Page: TfrxReportPage; Index: Integer);
begin
  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: TRect;
begin
  if FCrop and FSeparate then
  begin
    RFrom := Rect(FMinX, FMinY, FMaxX, FMaxY);
    RTo := Rect(0, FYOffset, FMaxX - FMinX, FYOffset + FMaxY - FMinY);
    FBitmap.Canvas.CopyRect(RTo, FBitmap.Canvas, RFrom);
    FBitmap.Width := FMaxX - FMinX;
    FBitmap.Height := FYOffset + FMaxY - FMinY;
  end;
  Save;
  FBitmap.Free;
end;

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