frrtfexp.pas

不错的报表工具

{******************************************}
{                                          }
{             FastReport v2.5              }
{          Adv. RTF export filter          }
{                                          }
{Copyright(c) 1998-2003 by FastReports Inc.}
{                                          }
{******************************************}

unit frRtfExp;

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;

function ComparePoints(Item1, Item2: Pointer): Integer;
function CompareObjects(Item1, Item2: Pointer): Integer;

const
  Xdivider = 8;
  Ydivider = 1.3;

type
TfrRtfExpSet = class(TForm)
  OK: TButton;
  Cancel: TButton;
    GroupPageSettings: TGroupBox;
    GroupPageRange: TGroupBox;
    LeftM: TLabel;
    Pages: TLabel;
    E_Range: TEdit;
    Descr: TLabel;
    E_LMargin: TEdit;
    TopM: TLabel;
    E_TMargin: TEdit;
    ScX: TLabel;
    E_ScaleX: TEdit;
    Label2: TLabel;
    ScY: TLabel;
    E_ScaleY: TEdit;
    Label9: TLabel;
    GroupCellProp: TGroupBox;
    CB_PageBreaks: TCheckBox;
    CB_Pictures: TCheckBox;
    procedure FormCreate(Sender: TObject);
 private
    procedure Localize;
end;


TObjCell = class(TObject)
public
  Value: integer;
end;

TObjPos = class(TObject)
public
  obj: integer;
  x,y: integer;
  dx, dy: integer;
end;

TfrRtfAdvExport = class(TfrExportFilter)
  private
    CurrentPage: integer;
    FirstPage: boolean;
    CurY: integer;
    RX: TList; // TObjCell
    RY: TList; // TObjCell
    ObjectPos: TList; // TObjPos
    PageObj: TList; // TfrView
    TempStream  : TStream;
    FontTable, ColorTable: TStringList;
    DataList    : TList;
    CY, LastY: integer;
    frExportSet: TfrRtfExpSet;
    pgList: TStringList;
    pgBreakList: TStringList;
    CntPics: integer;
    NewPage : boolean;
    expPageBreaks, expPictures: boolean;
    expScaleX, expScaleY, expTopMargin, expLeftMargin: Double;
    procedure ObjCellAdd(Vector: TList; Value: integer);
    procedure ObjPosAdd(Vector: TList; x, y, dx, dy, obj: integer);
    procedure DeleteMultiplePoint(Vector: TList);
    procedure ClearLastPage;
    procedure OrderObjectByCells;
    procedure ExportPage;
    function CleanReturns(Str: string): string;
    procedure AfterExport(const FileName: string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ShowModal: Word; override;
    procedure OnBeginDoc; override;
    procedure OnEndDoc; override;
    procedure OnEndPage; override;
    procedure OnBeginPage; override;
    procedure OnData(x, y: Integer; View: TfrView); override;
  published
    property ExportPictures : Boolean read expPictures write expPictures default True;
    property LeftMargin : Double read expLeftMargin write expLeftMargin;
    property PageBreaks : Boolean read expPageBreaks write expPageBreaks default True;
    property TopMargin : Double read expTopMargin write expTopMargin;
end;


implementation

uses FR_Const, FR_Utils, FR_Rich
{$IFDEF Delphi6}
, StrUtils
{$ENDIF};

{$R *.dfm}

const TemplateStr = '{\rtf1\ansi' + #13#10 + '\paperw%d\paperh%d\margl%d\margr%d\margt%d\margb%d';

function ComparePoints(Item1, Item2: Pointer): Integer;
begin
  Result := TObjCell(Item1).Value - TObjCell(Item2).Value;
end;

function CompareObjects(Item1, Item2: Pointer): Integer;
var
  r: integer;
begin
  r := TfrView(Item1).y - TfrView(Item2).y;
  if r = 0 then
    r := TfrView(Item1).x - TfrView(Item2).x;
  if r = 0 then
    r :=Length(TfrView(Item1).Memo.Text) - Length(TfrView(Item2).Memo.Text);
  Result := r;
end;

constructor TfrRtfAdvExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  frRegisterExportFilter(Self, frLoadStr(frRes + 1870), '*.rtf');
  RX := TList.Create;
  RY := TList.Create;
  PageObj := TList.Create;
  ObjectPos := TList.Create;
  pgList := TStringList.Create;
  pgBreakList := TStringList.Create;
  ShowDialog := True;
  expPageBreaks := True;
  expPictures := True;
  expScaleX := 1.0;
  expScaleY := 1.0;
end;

destructor TfrRtfAdvExport.Destroy;
begin
  ClearLastPage;
  frUnRegisterExportFilter(Self);
  RX.Destroy;
  RY.Destroy;
  PageObj.Destroy;
  ObjectPos.Destroy;
  pgList.Destroy;
  pgBreakList.Destroy;
  inherited;
end;

function TfrRtfAdvExport.CleanReturns(Str: string): string;
var
  i: integer;
begin
{   i := Pos(#13, Str);
   while i > 0 do
   begin
      if i > 0 then
      begin
        Delete(Str, i, 1);
        Insert(#13#10, Str, i);
      end;
      i := Pos(#13, Str);
   end;}
   i := Pos(#1, Str);
   while i > 0 do
   begin
      if i > 0 then Delete(Str, i, 1);
      i := Pos(#1, Str);
   end;
   Result := Str;
end;

procedure TfrRtfAdvExport.ClearLastPage;
var
  i: integer;
begin
  for i := 0 to RX.Count - 1 do TObjCell(RX[i]).Free;
  RX.Clear;
  for i := 0 to RY.Count - 1 do TObjCell(RY[i]).Free;
  RY.Clear;
  for i := 0 to PageObj.Count - 1 do
  begin
    if TfrView(PageObj[i]) is TfrMemoView then
      TfrMemoView(PageObj[i]).Destroy
    else
    if TfrView(PageObj[i]) is TfrPictureView then
      TfrPictureView(PageObj[i]).Destroy;
  end;
  PageObj.Clear;
  for i := 0 to ObjectPos.Count - 1 do TObjPos(ObjectPos[i]).Free;
  ObjectPos.Clear;
end;

procedure TfrRtfAdvExport.ObjCellAdd(Vector: TList; Value: integer);
var
   ObjCell: TObjCell;
begin
   ObjCell := TObjCell.Create;
   ObjCell.Value := Value;
   Vector.Add(ObjCell);
end;

procedure TfrRtfAdvExport.ObjPosAdd(Vector: TList; x, y, dx, dy, obj: integer);
var
    ObjPos: TObjPos;
begin
   ObjPos := TObjPos.Create;
   ObjPos.x := x;
   ObjPos.y := y;
   ObjPos.dx := dx;
   ObjPos.dy := dy;
   ObjPos.obj := Obj;
   Vector.Add(ObjPos);
end;

procedure TfrRtfAdvExport.DeleteMultiplePoint(Vector: TList);
var
  i: integer;
  point, lpoint: TObjCell;
begin
   if Vector.Count > 0 then
   begin
    i := 0;
    lpoint := TObjCell(Vector[i]);
    inc(i);
    while i <= Vector.Count - 1 do
    begin
      point := TObjCell(Vector[i]);
      if (point.Value = lpoint.Value) then
      begin
        point.Free;
        Vector.Delete(i);
      end
      else
      begin
        lpoint := point;
        inc(i);
      end;
    end;
   end;
end;

procedure TfrRtfAdvExport.OrderObjectByCells;
var
   obj, c, fx, fy, dx, dy, m, mi: integer;
begin
   for obj := 0 to PageObj.Count - 1 do
   begin
     fx := 0; fy := 0;
     dx := 1; dy := 1;
     for c := 0 to RX.Count - 1 do
       if TObjCell(RX[c]).Value = TfrView(PageObj[obj]).x then
       begin
          fx := c;
          m := TfrView(PageObj[obj]).x;
          mi := c + 1;
          while m < TfrView(PageObj[obj]).x + TfrView(PageObj[obj]).dx do
          begin
            m := m + TObjCell(RX[mi]).Value - TObjCell(RX[mi - 1]).Value;
            inc(mi);
          end;
          dx := mi - c - 1;
          break;
       end;
     for c := 0 to RY.Count - 1 do
       if TObjCell(RY[c]).Value = TfrView(PageObj[obj]).y then
       begin
          fy := c;
          m := TfrView(PageObj[obj]).y;
          mi := c + 1;
          while m < TfrView(PageObj[obj]).y + TfrView(PageObj[obj]).dy do
          begin
            m := m + TObjCell(RY[mi]).Value - TObjCell(RY[mi - 1]).Value;
            inc(mi);
          end;
          dy := mi - c - 1;
          break;
       end;
     ObjPosAdd(ObjectPos, fx, fy, dx, dy, obj);
   end;
end;

function TfrRtfAdvExport.ShowModal: Word;

var
  PageNumbers: string;

  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
 if ShowDialog then
 begin
  frExportSet := TfrRtfExpSet.Create(nil);
  frExportSet.E_ScaleX.Text := FloatToStr(Int(expScaleX*100));
  frExportSet.E_ScaleY.Text := FloatToStr(Int(expScaleY*100));
  frExportSet.E_TMargin.Text := FloatToStr(expTopMargin);
  frExportSet.E_LMargin.Text := FloatToStr(expLeftMargin);
  frExportSet.CB_Pictures.Checked := expPictures;
  Result := frExportSet.ShowModal;
  PageNumbers := frExportSet.E_Range.Text;
  expScaleX := StrToInt(frExportSet.E_ScaleX.Text) / 100;
  expScaleY := StrToInt(frExportSet.E_ScaleY.Text) / 100;
  expTopMargin := StrToFloat(frExportSet.E_TMargin.Text);
  expLeftMargin := StrToFloat(frExportSet.E_LMargin.Text);
  expPictures := frExportSet.CB_Pictures.Checked;
  frExportSet.Destroy;
 end
 else
   Result := mrOk;
 pgList.Clear;
 pgBreakList.Clear;
 ParsePageNumbers;
end;

procedure TfrRtfAdvExport.ExportPage;
var
  i, j, n, n1, x, y, dx, dy: Integer;
  s0, s, s1, s2: String;
  Str: TStream;
  bArr: Array[0..1023] of Byte;
  obj: TfrMemoView;
  objR : TfrRichView;

  function GetFontStyle(f: TFontStyles): String;
  begin
    Result := '';
    if f = [fsItalic] then Result := '\i';
    if f = [fsBold] then Result := Result + '\b';
    if f = [fsUnderline] then Result := Result + '\ul';