frxexportrtf.pas

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

{******************************************}
{                                          }
{             FastReport v3.0              }
{            RTF export filter             }
{                                          }
{         Copyright (c) 1998-2005          }
{          by Alexander Fediachov,         }
{             Fast Reports Inc.            }
{                                          }
{******************************************}

unit frxExportRTF;

interface

{$I frx.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, extctrls, ComObj, Printers, frxClass, JPEG, ShellAPI, frxExportMatrix
{$IFDEF Delphi6}, Variants {$ENDIF}, frxProgress, ComCtrls;

type
  TfrxRTFExportDialog = class(TForm)
    OkB: TButton;
    CancelB: TButton;
    GroupPageRange: TGroupBox;
    DescrL: TLabel;
    AllRB: TRadioButton;
    CurPageRB: TRadioButton;
    PageNumbersRB: TRadioButton;
    PageNumbersE: TEdit;
    GroupQuality: TGroupBox;
    WCB: TCheckBox;
    PageBreaksCB: TCheckBox;
    PicturesCB: TCheckBox;
    OpenCB: TCheckBox;
    SaveDialog1: TSaveDialog;
    procedure FormCreate(Sender: TObject);
  end;

  TfrxRTFExport = class(TfrxCustomExportFilter)
  private
    FColorTable: TStringList;
    FCurrentPage: Integer;
    FDataList: TList;
    FExportPageBreaks: Boolean;
    FExportPictures: Boolean;
    FFirstPage: Boolean;
    FFontTable: TStringList;
    FMatrix: TfrxIEMatrix;
    FOpenAfterExport: Boolean;
    FProgress: TfrxProgress;
    FShowProgress: Boolean;
    FWysiwyg: Boolean;
    FCreator: String;
    function ChangeReturns(Str: string): string;
    function TruncReturns(Str: string): string;
    function GetRTFBorders(Style: TfrxIEMStyle): string;
    function GetRTFColor(c: Integer): string;
    function GetRTFFontStyle(f: TFontStyles): String;
    function GetRTFFontColor(f: String): String;
    function GetRTFFontName(f: String): String;
    function GetRTFHAlignment(HAlign: TfrxHAlign) : String;
    function GetRTFVAlignment(VAlign: TfrxVAlign) : String;
    procedure ExportPage(Stream: TStream);
    procedure PrepareExport;
  public
    constructor Create(AOwner: TComponent); override;
    class function GetDescription: String; 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;
  published
    property ExportPageBreaks: Boolean read FExportPageBreaks write FExportPageBreaks default True;
    property ExportPictures: Boolean read FExportPictures write FExportPictures default True;
    property OpenAfterExport: Boolean read FOpenAfterExport
      write FOpenAfterExport default False;
    property ShowProgress: Boolean read FShowProgress write FShowProgress;
    property Wysiwyg: Boolean read FWysiwyg write FWysiwyg;
    property Creator: String read FCreator write FCreator;
  end;


implementation

uses frxUtils, frxRes, frxrcExports;

{$R *.dfm}

const
  Xdivider = 15.1;
  Ydivider = 14.2;
  PageDivider = 15.02;
  MargDivider = 56.6;
  FONT_DIVIDER = 15;
  IMAGE_DIVIDER = 25.3;


{ TfrxRTFExport }

constructor TfrxRTFExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ShowDialog := True;
  FExportPageBreaks := True;
  FExportPictures := True;
  FShowProgress := True;
  FWysiwyg := True;
  FCreator := 'FastReport http://www.fast-report.com'
end;

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

function TfrxRTFExport.TruncReturns(Str: string): string;
begin
  Str := StringReplace(Str, #1, '', [rfReplaceAll]);
  if Copy(Str, Length(Str) - 1, 2) = #13#10 then
    Delete(Str, Length(Str) - 1, 2);
  Result := Str;
end;

function TfrxRTFExport.ChangeReturns(Str: string): string;
begin
  Str := StringReplace(Str, '\', '\\', [rfReplaceAll]);
  Str := StringReplace(Str, '{', '\{', [rfReplaceAll]);
  Str := StringReplace(Str, '}', '\}', [rfReplaceAll]);
  Str := StringReplace(Str, #13#10, '\line'#13#10, [rfReplaceAll]);
  Result := Str;
end;

function TfrxRTFExport.GetRTFBorders(Style: TfrxIEMStyle): string;
var
  brdrw: String;
  brdrc: String;
  brdrs: String;
begin
  Result := '';
  brdrw := '\brdrs\brdrw' + IntToStr(Round(Style.FrameWidth * 20));
  brdrc := '\brdrcf' + GetRTFFontColor(GetRTFColor(Style.FrameColor));
  if Style.FrameStyle = fsDouble then
    brdrs := '\brdrdashdd'
  else if Style.FrameStyle <> fsSolid then
    brdrs := '\brdrdashsm'
  else brdrs := '';
  if ftTop in Style.FrameTyp then
    Result := Result + '\clbrdrt' + brdrw + brdrc + brdrs;
  if ftLeft in Style.FrameTyp then
    Result := Result + '\clbrdrl' + brdrw + brdrc + brdrs;
  if ftBottom in Style.FrameTyp then
    Result := Result + '\clbrdrb' + brdrw + brdrc + brdrs;
  if ftRight in Style.FrameTyp then
    Result := Result + '\clbrdrr' + brdrw + brdrc + brdrs;
end;

function TfrxRTFExport.GetRTFColor(c: Integer): string;
begin
  Result := '\red' + IntToStr(GetRValue(c)) +
            '\green' + IntToStr(GetGValue(c)) +
            '\blue' + IntToStr(GetBValue(c)) + ';'
end;

function TfrxRTFExport.GetRTFFontStyle(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';
end;

function TfrxRTFExport.GetRTFFontColor(f: String): String;
var
  i: Integer;
begin
  i := FColorTable.IndexOf(f);
  if i <> -1 then
    Result := IntToStr(i + 1)
  else
  begin
    FColorTable.Add(f);
    Result := IntToStr(FColorTable.Count);
  end;
end;

function TfrxRTFExport.GetRTFFontName(f: String): String;
var
  i: Integer;
begin
  i := FFontTable.IndexOf(f);
  if i <> -1 then
    Result := IntToStr(i)
  else
  begin
    FFontTable.Add(f);
    Result := IntToStr(FFontTable.Count - 1);
  end;
end;

function TfrxRTFExport.GetRTFHAlignment(HAlign: TfrxHAlign) : String;
begin
  Result:='';
  if (HAlign = haLeft) then Result := Result + '\ql';
  if (HAlign = haRight) then Result := Result + '\qr';
  if (HAlign = haCenter) then Result := Result + '\qc';
  if Result = '' then Result := '\ql';
end;

function TfrxRTFExport.GetRTFVAlignment(VAlign: TfrxVAlign) : String;
begin
  Result:='';
  if (VAlign = vaTop) then Result := Result + '\clvertalt';
  if (VAlign = vaCenter) then Result := Result + '\clvertalc';
  if (VAlign = vaBottom) then Result := Result + '\clvertalb';
  if Result = '' then Result := '\ql';
end;

procedure TfrxRTFExport.PrepareExport;
var
  i, j, x, y, n, n1, fx: Integer;
  s, s0, s1, s2: String;
  Obj: TfrxIEMObject;
  RepPos: TStringList;
begin
  for y := 0 to FMatrix.Height - 1 do
    for x := 0 to FMatrix.Width - 1 do
    begin
      i := FMatrix.GetCell(x, y);
      if (i <> -1) then
      begin
        Obj := FMatrix.GetObjectById(i);
        if Obj.Counter <> -1 then
        begin
          Obj.Counter := -1;
          GetRTFFontColor(GetRTFColor(Obj.Style.Color));
          GetRTFFontColor(GetRTFColor(Obj.Style.FrameColor));
          if Obj.IsRichText then
          begin
            RepPos := TStringList.Create;
            s := Obj.Memo.Text;
            fx := Pos('{\fonttbl', s);
            Delete(s, 1, fx + 8);
            i := 1;
            RepPos.Clear;
            while (i < Length(s)) and (s[i] <> '}') do
            begin
              while (i < Length(s)) and (s[i] <> '{') do
                Inc(i);
              Inc(i);
              j := i;
              while (j < Length(s)) and (s[j] <> '}') do
                Inc(j);
              Inc(j);
              s1 := Copy(s, i , j - i - 2);
              i := j;
              j := Pos(' ', s1);
              s2 := Copy(s1, j + 1, Length(s1) - j + 1);
              s0 := '\f' + GetRTFFontName(s2);
              j := Pos('\f', s1);
              n := j + 1;
              while (n < Length(s1)) and (s1[n] <> '\') and (s1[n] <> ' ') do
                Inc(n);
              s2 := Copy(s1, j, n - j);
              j := Pos('}}', s);
              s1 := Copy(s, j + 2, Length(s) - j - 1);
              j := j + 2;
              n := 1;
              while n > 0 do
              begin
                n := Pos(s2, s1);
                if n > 0 then
                begin
                  if RepPos.IndexOf(IntToStr(n + j - 1)) = -1 then
                  begin
                    RepPos.Add(IntToStr(n + j - 1));
                    Delete(s, n + j - 1, Length(s2));
                    Insert(s0, s, n + j - 1);
                  end;
                  j := j + n + Length(s2) - 1;
                  s1 := Copy(s, j, Length(s) - j + 1);
                end;
              end;
            end;
            fx := Pos('}}', s);
            if fx > 0 then
              Delete(s, 1, fx + 1);
            fx := Pos('{\colortbl', s);
            if fx > 0 then
            begin
              Delete(s, 1, fx + 11);
              i := 1;
              n1 := 1;
              RepPos.Clear;
              while (i < Length(s)) and (s[i] <> '}') do
              begin
                while (i < Length(s)) and (s[i] <> '\') do
                  Inc(i);
                j := i;
                while (j < Length(s)) and (s[j] <> ';') do
                  Inc(j);
                Inc(j);
                s1 := Copy(s, i , j - i);
                i := j;
                s0 := '\cf' + GetRTFFontColor(s1);
                s2 := '\cf' + IntToStr(n1);
                j := Pos(';}', s);
                s1 := Copy(s, j + 2, Length(s) - j - 1);
                j := j + 2;
                n := 1;
                while n > 0 do
                begin
                  n := Pos(s2, s1);
                  if n > 0 then
                  begin
                    if RepPos.IndexOf(IntToStr(n + j - 1)) = -1 then
                    begin
                      RepPos.Add(IntToStr(n + j - 1));
                      Delete(s, n + j - 1, Length(s2));
                      Insert(s0, s, n + j - 1);
                    end;
                    j := j + n + Length(s2) - 1;
                    s1 := Copy(s, j, Length(s) - j + 1);
                  end;
                end;
                Inc(n1);
              end;
              fx := Pos(';}', s);
              if fx > 0 then
                Delete(s, 1, fx + 1);
            end;
            fx := Pos('{\stylesheet', s);
            if fx > 0 then
            begin
              Delete(s, 1, fx + 12);
              fx := Pos('}}', s);
              if fx > 0 then
                Delete(s, 1, fx + 1);
            end;
            s := StringReplace(s, '\pard', '', [rfReplaceAll]);
            Delete(s, Length(s) - 3, 3);
            Obj.Memo.Text := s;
            RepPos.Free;
          end else if Obj.IsText then
          begin
            GetRTFFontColor(GetRTFColor(Obj.Style.Font.Color));
            GetRTFFontName(Obj.Style.Font.Name);
          end;
        end;
      end;
    end;
end;

procedure TfrxRTFExport.ExportPage(Stream: TStream);
var
  i, j, x, y, fx, fy, dx, dy, n, n1, pbk: Integer;
  dcol, drow, xoffs: Integer;
  buff, s, s0, s1, s2: String;
  CellsLine: String;