frexpimg.pas

来自「不错的报表工具」· PAS 代码 · 共 644 行 · 第 1/2 页

PAS
644 行
字号
12
{******************************************}
{                                          }
{             FastReport v2.5              }
{           Images export filter           }
{                                          }
{Copyright(c) 1998-2003 by FastReports Inc.}
{                                          }
{******************************************}

unit frexpimg;

interface

{$I Fr.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, extctrls, Clipbrd, Printers, FR_Class
{$IFDEF Delphi6}
, Variants
{$ENDIF},
  FR_Progr, FR_Ctrls
{$IFDEF JPEG}
, jpeg
{$ENDIF};

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

type
  TfrImgFltSet = class(TForm)
    OK: TButton;
    Cancel: TButton;
    GroupPageRange: TGroupBox;
    Label7: TLabel;
    E_Range: TEdit;
    Label1: TLabel;
    GroupBox1: TGroupBox;
    CropPage: TCheckBox;
    Label2: TLabel;
    Quality: TEdit;
    Mono: TCheckBox;
    procedure FormCreate(Sender: TObject);
  private
    procedure Localize;
  end;

  TfrImgFltExport = class(TfrExportFilter)
  private
    CurrentPage: integer;
    Canvas: TBitmap;
    MaxX, MaxY: Integer;
    MinX, MinY: Integer;
    frExportSet: TfrImgFltSet;
    pgList: TStringList;
    JPGQuality: integer;
    Crop: Boolean;
    FMono: Boolean;
    procedure AfterExport(const FileName: string);
    procedure Save; virtual; abstract;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ShowModal: Word; override;
    procedure OnBeginDoc; override;
    procedure OnEndPage; override;
    procedure OnBeginPage; override;
    procedure OnData(x, y: Integer; View: TfrView); override;
  published
    property Quality: integer read JPGQuality write JPGQuality default 90;
    property CropImages: Boolean read Crop write Crop default True;
    property Monochrome: Boolean read FMono write FMono default False;
  end;

  TfrBMPExport = class(TfrImgFltExport)
  private
    procedure Save; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property CropImages;
    property Monochrome;
  end;

  TfrTIFFExport = class(TfrImgFltExport)
  private
    procedure Save; override;
    procedure SaveTiffToStream(Stream: TStream; Bitmap: TBitmap);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property CropImages;
    property Monochrome;
  end;

{$IFDEF JPEG}
  TfrJPEGExport = class(TfrImgFltExport)
  private
    procedure Save; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Quality;
    property CropImages;
    property Monochrome;
  end;
{$ENDIF}

implementation

uses FR_Const, FR_Utils;

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

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);
  X_Res_Value: array[0..7] of Byte = ($6D, $03, $00, $00, $0A, $00, $00, $00);
  Y_Res_Value: array[0..7] of Byte = ($6D, $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);

constructor TfrImgFltExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  pgList := TStringList.Create;
  JPGQuality := 90;
  ShowDialog := True;
  Crop := True;
  Monochrome := False;
end;

constructor TfrBMPExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  frRegisterExportFilter(Self, frLoadStr(frRes + 1875), '*.bmp');
end;

constructor TfrTIFFExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  frRegisterExportFilter(Self, frLoadStr(frRes + 1876), '*.tif');
end;

destructor TfrImgFltExport.Destroy;
begin
  pgList.Destroy;
  inherited;
end;

destructor TfrBMPExport.Destroy;
begin
  frUnRegisterExportFilter(Self);
  inherited;
end;

destructor TfrTIFFExport.Destroy;
begin
  frUnRegisterExportFilter(Self);
  inherited;
end;

{$IFDEF JPEG}
constructor TfrJPEGExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  frRegisterExportFilter(Self, frLoadStr(frRes + 1877), '*.jpg');
end;

destructor TfrJPEGExport.Destroy;
begin
  frUnRegisterExportFilter(Self);
  inherited;
end;

procedure TfrJPEGExport.Save;
var
  Image: TJPEGImage;
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(ChangeFileExt(FileName, '_' +
    IntToStr(CurrentPage) + '.jpg'), fmCreate);
  Image := TJPEGImage.Create;
  Image.CompressionQuality := JPGQuality;
  Image.Assign(Canvas);
  Image.SaveToStream(Stream);
  Image.Free;
  Stream.Free;
end;
{$ENDIF}

function TfrImgFltExport.ShowModal: Word;
var
  PageNumbers: string;
  Res: integer;

  procedure ParsePageNumbers;
  var
    i, j, n1, n2: Integer;
    s: string;
    IsRange: Boolean;
  begin
    s := PageNumbers;
    while Pos(' ', s) <> 0 do
      Delete(s, Pos(' ', s), 1);
    if s = '' then
      Exit;
    s := s + ',';
    i := 1;
    j := 1;
    n1 := 1;
    IsRange := False;
    while i <= Length(s) do
    begin
      if s[i] = ',' then
      begin
        n2 := StrToInt(Copy(s, j, i - j));
        j := i + 1;
        if IsRange then
          while n1 <= n2 do
          begin
            pgList.Add(IntToStr(n1));
            Inc(n1);
          end
        else
          pgList.Add(IntToStr(n2));
        IsRange := False;
      end
      else if s[i] = '-' then
      begin
        IsRange := True;
        n1 := StrToInt(Copy(s, j, i - j));
        j := i + 1;
      end;
      Inc(i);
    end;
  end;

begin
  Res := mrOk;
  if ShowDialog then
  begin
    frExportSet := TfrImgFltSet.Create(nil);
    frExportSet.Quality.Text := IntToStr(JPGQuality);
    frExportSet.CropPage.Checked := Crop;
    frExportSet.Mono.Checked := Monochrome;
{$IFDEF JPEG}
    if Self is TfrJPEGExport then
      frExportSet.Quality.Enabled := true
    else
{$ENDIF}
      frExportSet.Quality.Enabled := false;
    Res := frExportSet.ShowModal;
    JPGQuality := StrToInt(frExportSet.Quality.Text);
    Crop := frExportSet.CropPage.Checked;
    PageNumbers := frExportSet.E_Range.Text;
    Monochrome := frExportSet.Mono.Checked;
12

frexpimg.pas - 源码说明

本页面展示了「不错的报表工具」中的 frexpimg.pas 源码文件，采用 PAS 编程语言编写，共 644 行代码。您可以在线阅读完整代码内容，也可以返回资源详情页下载完整源码包进行本地学习和开发。

虫虫下载站收录了大量与报表相关的技术资源，包括源代码、技术文档、电路图等，是电子工程师和嵌入式开发者的专业学习平台。

⌨️ 快捷键说明

复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?