frxexportrtf.pas

这个是功能强大的报表软件

{******************************************}
{                                          }
{             FastReport v4.0              }
{            RTF export filter             }
{                                          }
{         Copyright (c) 1998-2008          }
{          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, frxGraphicUtils;

type
  TfrxHeaderFooterMode = (hfText, hfPrint, hfNone);

  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;
    ContinuousCB: TCheckBox;
    HeadFootL: TLabel;
    PColontitulCB: TComboBox;
    procedure FormCreate(Sender: TObject);
    procedure PageNumbersEChange(Sender: TObject);
    procedure PageNumbersEKeyPress(Sender: TObject; var Key: Char);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  end;

  TfrxRTFExport = class(TfrxCustomExportFilter)
  private
    FColorTable: TStringList;
    FCurrentPage: Integer;
    FDataList: TList;
    FExportPageBreaks: Boolean;
    FExportPictures: Boolean;
    FFirstPage: Boolean;
    FFontTable: TStringList;
    FCharsetTable: TStringList;
    FMatrix: TfrxIEMatrix;
    FOpenAfterExport: Boolean;
    FProgress: TfrxProgress;
    FWysiwyg: Boolean;
    FCreator: String;
    FHeaderFooterMode: TfrxHeaderFooterMode;
    FAutoSize: Boolean;
    FExportEMF: Boolean;

    function TruncReturns(const Str: WideString): WideString;
    function GetRTFBorders(const Style: TfrxIEMStyle): string;
    function GetRTFColor(const c: DWORD): string;
    function GetRTFFontStyle(const f: TFontStyles): String;
    function GetRTFFontColor(const f: String): String;
    function GetRTFFontName(const f: String; const charset: Integer): String;
    function GetRTFHAlignment(const HAlign: TfrxHAlign) : String;
    function GetRTFVAlignment(const VAlign: TfrxVAlign) : String;
    function StrToRTFSlash(const Value: WideString): WideString;
    function StrToRTFUnicodeEx(const Value: WideString): String;
    function StrToRTFUnicode(const Value: WideString): String;
    procedure ExportPage(const 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 ExportEMF: Boolean read FExportEMF write FExportEMF;
    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 Wysiwyg: Boolean read FWysiwyg write FWysiwyg;
    property Creator: String read FCreator write FCreator;
    property SuppressPageHeadersFooters;
    property HeaderFooterMode: TfrxHeaderFooterMode read FHeaderFooterMode write FHeaderFooterMode;
    property AutoSize: Boolean read FAutoSize write FAutoSize;
    property OverwritePrompt;
  end;


implementation

uses frxUtils, frxFileUtils, frxRes, frxrcExports;

{$R *.dfm}

const
  Xdivider = 15.05;
  Ydivider = 15;
  Ydivider_last = 14.5;
  PageDivider = 15.02;
  MargDivider = 56.48;
  FONT_DIVIDER = 15;
  IMAGE_DIVIDER = 25.3;


{ TfrxRTFExport }

constructor TfrxRTFExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ShowDialog := True;
  FExportPageBreaks := True;
  FExportPictures := True;
  FWysiwyg := True;
  FHeaderFooterMode := hfText;
  FAutoSize := False;
  FCreator := 'FastReport';
  FilterDesc := frxGet(8504);
  DefaultExt := frxGet(8505);
  FExportEMF := True;
end;

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

function TfrxRTFExport.TruncReturns(const Str: WideString): WideString;
var
  l: Integer;
begin
  l := Length(Str);
  if (l > 1) and (Str[l - 1] = #13) and (Str[l] = #10) then
    Result := Copy(Str, 1, l - 2)
  else
    Result := Str;
end;

function TfrxRTFExport.StrToRTFSlash(const Value: WideString): WideString;
var
  i: integer;
begin
  result := '';
  for i := 1 to Length(Value) do
  begin
    if Value[i] = '\' then
      result := result + '\\'
    else if Value[i] = '{' then
      result := result + '\{'
    else if Value[i] = '}' then
      result := result + '\}'
    else if (Value[i] = #13) and (i < (Length(Value) - 1)) and (Value[i + 1] = #10) then
      result := result + '\line'#13
    else
      result := result + Value[i];
  end;
end;

function TfrxRTFExport.StrToRTFUnicodeEx(const Value: WideString): String;
var
  s: WideString;
begin
  s := StrToRTFSlash(Value);
  Result := StrToRTFUnicode(s);
end;

function TfrxRTFExport.StrToRTFUnicode(const Value: WideString): String;
var
  i: integer;
  pwc: ^Word;
begin
  result := '';
  for i := 1 to Length(Value) do
  begin
    pwc := @Value[i];
    if pwc^ > 127 then
      result := result + '\u' + IntToStr(pwc^) + '\''3f'
    else
      result := result + Chr(pwc^);
  end;
end;

function TfrxRTFExport.GetRTFBorders(const Style: TfrxIEMStyle): string;
var
  brdrw: String;
  brdrc: String;
  brdrs: String;
begin
{$IFNDEF FR_DEBUG}
  Result := '';
  brdrw := '\brdrs\brdrw' + IntToStr(Round(Style.FrameWidth * 20));
  brdrc := '\brdrcf' + GetRTFFontColor(GetRTFColor(Style.FrameColor));
  if Style.FrameStyle = fsDouble then
    brdrs := '\brdrdb'
  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;
{$ELSE}
  Result := '';
  brdrw := '\brdrs\brdrw' + IntToStr(Round(Style.FrameWidth * 20));
  brdrc := '\brdrcf' + GetRTFFontColor(GetRTFColor(Style.FrameColor));
  brdrs := '';
  Result := Result + '\clbrdrt' + brdrw + brdrc + brdrs;
  Result := Result + '\clbrdrl' + brdrw + brdrc + brdrs;
  Result := Result + '\clbrdrb' + brdrw + brdrc + brdrs;
  Result := Result + '\clbrdrr' + brdrw + brdrc + brdrs;
{$ENDIF}
end;

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

function TfrxRTFExport.GetRTFFontStyle(const f: TFontStyles): String;
begin
  Result := '';
  if fsItalic in f then Result := '\i';
  if fsBold in f then Result := Result + '\b';
  if fsUnderline in f then Result := Result + '\ul';
end;

function TfrxRTFExport.GetRTFFontColor(const 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(const f: String; const Charset: Integer): String;
var
  i: Integer;
begin
  i := FFontTable.IndexOf(f);
  if i <> -1 then
    Result := IntToStr(i)
  else
  begin
    FFontTable.Add(f);
    FCharsetTable.Add(IntToStr(charset));
    Result := IntToStr(FFontTable.Count - 1);
  end;
end;

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

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

procedure TfrxRTFExport.PrepareExport;
var
  i, j, x, y, n, n1, fx: Integer;
  s, s0, s1, s2: String;
  Obj: TfrxIEMObject;
  RepPos: TStringList;

  function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer;
  var
    I,X: Integer;
    Len, LenSubStr: Integer;
  begin
    if Offset = 1 then
      Result := Pos(SubStr, S)
    else
    begin
      I := Offset;
      LenSubStr := Length(SubStr);
      Len := Length(S) - LenSubStr + 1;
      while I <= Len do
      begin
        if S[I] = SubStr[1] then
        begin
          X := 1;
          while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do
            Inc(X);
          if (X = LenSubStr) then
          begin
            Result := I;
            exit;
          end;
        end;
        Inc(I);
      end;
      Result := 0;
    end;
  end;

  function TagClean(const Str: String; const BegCut: String; const EndCut: String): String;
  var
    i, j, k: Integer;
  begin
    Result := Str;
    i := 1;
    k := Length(BegCut);
    while i > 0 do
    begin
      i := Pos(BegCut, Result);
      if i > 0 then
      begin
        j := PosEx(EndCut, Result, i + k);
        Delete(Result, i, j - i);
      end;
    end;
  end;

  function TagClean2(const Str: String; const BegCut: String; const EndCut1: String; const EndCut2: String): String;
  var
    i, j1, j2, k: Integer;
  begin
    Result := Str;
    i := 1;
    k := Length(BegCut);
    while i > 0 do
    begin
      i := Pos(BegCut, Result);
      if i > 0 then
      begin
        j1 := PosEx(EndCut1, Result, i + k);
        j2 := PosEx(EndCut2, Result, i + k);
        if ((j1 < j2) or (j2 = 0)) and (j1 <> 0) then
          Delete(Result, i, j1 - i)
        else
        if (j2 <> 0) then
          Delete(Result, i, j2 - i)
      end;
    end;
  end;

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));
//// RICH TEXT PREPARE START
          if Obj.IsRichText then
          begin


            RepPos := TStringList.Create;
            try
              s := Obj.Memo.Text;
              fx := Pos('{\fonttbl', s);
              Delete(s, 1, fx + 8);
              i := 1;
              RepPos.Clear;