qexport4rtf.pas

Advanced.Export.Component.v4.01.rar,delphi 第三方控件

unit QExport4RTF;

{$I VerCtrl.inc}

interface

uses
  QExport4, Classes, QExport4RTFList, QExport4IniFiles, QExport4Types
  {$IFDEF WIN32}
    {$IFNDEF NOGUI}, Graphics{$ELSE}, QExport4Graphics{$ENDIF}
  {$ENDIF}
  {$IFDEF LINUX}
    {$IFNDEF NOGUI}, QGraphics{$ELSE}, QExport4Graphics{$ENDIF}
  {$ENDIF};

type
  TrtfStripType = (stNone, stCol, stRow);
  TrtfTextAlignment = (talLeft, talRight, talCenter, talFill);

  TrtfStyle = class(TCollectionItem)
  private
    FFont: TFont;
    FBackgroundColor: TColor;
    FHighlightColor: TColor;
    FAllowHighlight: boolean;
    FAllowBackground: boolean;
    FAlignment: TrtfTextAlignment;
    procedure SetFont(const Value: TFont);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure SetDefault; virtual;
    procedure SaveToIniFile(IniFile: TQIniFile; const Section: string); virtual;
    procedure LoadFromIniFile(IniFile: TQIniFile; const Section: string); virtual;
  published
    property Font: TFont read FFont write SetFont;
    property BackgroundColor: TColor read FBackgroundColor
      write FBackgroundColor default clWhite;
    property HighlightColor: TColor read FHighlightColor
      write FHighlightColor default clWhite;
    property AllowHighlight: boolean read FAllowHighlight
      write FAllowHighLight default false;
    property AllowBackground: boolean read FAllowBackground
      write FAllowBackground default true;
    property Alignment: TrtfTextAlignment read FAlignment
      write FAlignment default talLeft;
  end;

  TrtfStyles = class(TCollection)
  private
    FHolder: TPersistent;
  protected
    function GetOwner: TPersistent; override;
    function GetItem(Index: integer): TrtfStyle;
    procedure SetItem(Index: integer; Value: TrtfStyle);
  public
    constructor Create(Holder: TPersistent);
    function Add: TrtfStyle;
    procedure SaveToIniFile(IniFile: TQIniFile; const SectionPrefix: string);
    procedure LoadFromIniFile(IniFile: TQIniFile; const SectionPrefix: string); 

    property Holder: TPersistent read FHolder;
    property Items[Index: integer]: TrtfStyle read GetItem
      write SetItem; default;
  end;

  TRTFOptions = class(TPersistent)
  private
    FHolder: TPersistent;
//    FDefaultCaptionAlign: TQExportColAlign;
    FCaptionAligns: TStrings;
    FCaptionStyle: TrtfStyle;
    FDataStyle: TrtfStyle;
    FPageOrientation: TQExportPageOrientation;
    FStripStyles: TrtfStyles;
    FStripType: TrtfStripType;
    FHeaderStyle: TrtfStyle;
    FFooterStyle: TrtfStyle;
    procedure SetCaptionAligns(const Value: TStrings);
    procedure SetCaptionStyle(const Value: TrtfStyle);
    procedure SetDataStyle(const Value: TrtfStyle);
    procedure SetStripStyles(const Value: TrtfStyles);
    procedure SetHeaderStyle(const Value: TrtfStyle);
    procedure SetFooterStyle(const Value: TrtfStyle);
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create(Holder: TPersistent);
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
//    property DefaultCaptionAlign: TQExportColAlign
//      read FDefaultCaptionAlign write FDefaultCaptionAlign
//      default ecaCenter;
    property CaptionAligns: TStrings read FCaptionAligns
      write SetCaptionAligns;
    property CaptionStyle: TrtfStyle read FCaptionStyle
      write SetCaptionStyle;
    property DataStyle: TrtfStyle read FDataStyle
      write SetDataStyle;
    property PageOrientation: TQExportPageOrientation
      read FPageOrientation write FPageOrientation
      default poPortrait;
    property StripStyles: TrtfStyles read FStripStyles
      write SetStripStyles;
    property StripType: TrtfStripType read FStripType
      write FStripType default stNone;
    property HeaderStyle: TrtfStyle read FHeaderStyle
      write SetHeaderStyle;
    property FooterStyle: TrtfStyle read FFooterStyle
      write SetFooterStyle;
  end;

  TrtfGetStyleEvent = procedure(Sender: TObject;
    Style: TrtfStyle) of object;
  TrtfGetCaptionStyleEvent = procedure(Sender: TObject; ColNo: integer;
    Style: TrtfStyle) of object;
  TrtfGetDataStyleEvent = procedure(Sender: TObject; Row, Col: integer;
    Style: TrtfStyle) of object;

  TQExport4RTF = class(TQExport4FormatText)
  private
    FOptions: TRTFOptions;
    FOnGetHeaderStyle: TrtfGetStyleEvent;
    FOnGetCaptionStyle: TrtfGetCaptionStyleEvent;
    FOnGetDataStyle: TrtfGetDataStyleEvent;
    FOnGetFooterStyle: TrtfGetStyleEvent;
    procedure SetOptions(const Value: TRTFOptions);
    procedure StyleToStrs(Style: TrtfStyle; var AlignStr, FontStr, ColorStr,
      AttrStr, BackgroundStr, HighlightStr: string);
  protected
    procedure BeginExport; override;
    procedure BeforeExport; override;
    function GetColCaption(Index: integer): string; override;
    procedure WriteCaptionRow; override;
    function GetColData(ColValue: QEString;
      Column: TQExportColumn): QEString; override;
    procedure WriteDataRow; override;
    procedure EndExport; override;

    function GetWriter: TQRTFWriter;
    function GetWriterClass: TQExportWriterClass; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Abort; override;
    function NormalString(const S: QEString): QEString; override;
  published
    property Options: TRTFOptions read FOptions write SetOptions;

    property ColumnsWidth;
    property ColumnsAlign;

    property OnGetHeaderStyle: TrtfGetStyleEvent
      read FOnGetHeaderStyle write FOnGetHeaderStyle;
    property OnGetCaptionStyle: TrtfGetCaptionStyleEvent
      read FOnGetCaptionStyle write FOnGetCaptionStyle;
    property OnGetDataStyle: TrtfGetDataStyleEvent
      read FOnGetDataStyle write FOnGetDataStyle;
    property OnGetFooterStyle: TrtfGetStyleEvent
      read FOnGetFooterStyle write FOnGetFooterStyle;
  end;

implementation

uses SysUtils, QExport4Common, QExport4EmsWideStrUtils
     {$IFDEF WIN32}
     , Windows
     {$ENDIF}
     {$IFDEF LINUX}
       {$IFNDEF NOGUI}, QForms {$ENDIF}
     {$ENDIF};

{ TRTFOptions }

constructor TRTFOptions.Create(Holder: TPersistent);
begin
  inherited Create;
  FHolder := Holder;
//  FDefaultCaptionAlign := ecaCenter;
  FCaptionAligns := TStringList.Create;
  FDataStyle := TrtfStyle.Create(nil);
  FDataStyle.Font.Name := 'Arial';
  FDataStyle.Font.Size := 10;
  FCaptionStyle := TrtfStyle.Create(nil);
  FCaptionStyle.Assign(FDataStyle);
  FCaptionStyle.Font.Style := FCaptionStyle.Font.Style + [fsBold];
  FCaptionStyle.Alignment := talCenter;
  FPageOrientation := poPortrait;
  FStripStyles := TrtfStyles.Create(Self);
  FStripType := stNone;
  FHeaderStyle := TrtfStyle.Create(nil);
  FFooterStyle := TrtfStyle.Create(nil);
end;

destructor TRTFOptions.Destroy;
begin
  FFooterStyle.Free;
  FHeaderStyle.Free;
  FStripStyles.Free;
  FCaptionStyle.Free;
  FDataStyle.Free;
  FCaptionAligns.Free;
  inherited;
end;

procedure TRTFOptions.Assign(Source: TPersistent);
begin
  if Source is TRTFOptions then begin
//    DefaultCaptionAlign := (Source as TRTFOptions).DefaultCaptionAlign;
    CaptionAligns := (Source as TRTFOptions).CaptionAligns;
    CaptionStyle := (Source as TRTFOptions).CaptionStyle;
    DataStyle := (Source as TRTFOptions).DataStyle;
    PageOrientation := (Source as TRTFOptions).PageOrientation;
    StripStyles := (Source as TRTFOptions).StripStyles;
    StripType := (Source as TRTFOptions).StripType;
    HeaderStyle := (Source as TRTFOptions).HeaderStyle;
    FooterStyle := (Source as TRTFOptions).FooterStyle;
    Exit;
  end;
  inherited;
end;

function TRTFOptions.GetOwner: TPersistent;
begin
  Result := FHolder;
end;

procedure TRTFOptions.SetCaptionAligns(const Value: TStrings);
begin
  FCaptionAligns.Assign(Value);
end;

procedure TRTFOptions.SetCaptionStyle(const Value: TrtfStyle);
begin
  FCaptionStyle.Assign(Value);
end;

procedure TRTFOptions.SetDataStyle(const Value: TrtfStyle);
begin
  FDataStyle.Assign(Value);
end;

procedure TRTFOptions.SetStripStyles(const Value: TrtfStyles);
begin
  FStripStyles.Assign(Value);
end;

procedure TRTFOptions.SetHeaderStyle(const Value: TrtfStyle);
begin
  FHeaderStyle.Assign(Value);
end;

procedure TRTFOptions.SetFooterStyle(const Value: TrtfStyle);
begin
  FFooterStyle.Assign(Value);
end;

{ TQExport4RTF }

constructor TQExport4RTF.Create(AOwner: TComponent);
begin
  inherited;
  FOptions := TRTFOptions.Create(Self);
end;

destructor TQExport4RTF.Destroy;
begin
  FOptions.Free;
  inherited;
end;

procedure TQExport4RTF.Abort;
var
  i: integer;
  {$IFDEF QE_UNICODE}
  TempStr, NewResult, TempCodeString: WideString;
  Code: Word;
  stlen, j, k: Integer;
  {$ENDIF}
begin
  with GetWriter do begin
    WriteLn('\pard');
    WritePara;
    for i := 0 to Footer.Count - 1 do begin
      WritePara;
      {$IFDEF QE_UNICODE}
      NewResult := '';
      TempStr := NormalString(Footer[i]);
      stlen := 0;
      //finding complete string length
      for j := 1 to Length(TempStr) do
      begin
        Code := Word(TempStr[j]);
        if not (Code in [Word(#13), Word(#10), Word('\')]) then
          stlen := stlen + 3 + Length(IntToStr(Code))
        else
          stlen := stlen + 1;
      end;
      SetLength(NewResult, stlen);
      stlen := 1;
      //Changing to unicode
      for j := 1 to Length(TempStr) do
      begin
        Code := Word(TempStr[j]);
        if not (Code in [Word(#13), Word(#10), Word('\')]) then
        begin
          TempCodeString := IntToStr(Code);
          NewResult[stlen] := '\';
          NewResult[stlen + 1] := 'u';
          for k := 1 to Length(TempCodeString) do
            NewResult[stlen + 1 + k] := TempCodeString[k];
          NewResult[stlen + 2 + Length(TempCodeString)] := '?';
          stlen := stlen + 3 + Length(TempCodeString);
        end
        else
        begin
          NewResult[stlen] := TempStr[j];
          stlen := stlen + 1;
        end;
      end;
      WriteLn(NewResult);
      {$ELSE}
      WriteLn(NormalString(Footer[i]));
      {$ENDIF}
    end;
  end;
  inherited;
end;

procedure TQExport4RTF.BeginExport;
var
  fti: TRTFFontTableItem;
  cti: TRTFColorTableItem;
  AlignStr, FontStr, ColorStr, AttrStr,
  BackgroundStr, HighlightStr, FormatStr: string;
  N, CurRM, i: integer;
  Style: TrtfStyle;
  {$IFDEF QE_UNICODE}
  TempStr, NewResult, TempCodeString: WideString;
  Code: Word;
  stlen, j, k: Integer;
  {$ENDIF}
begin
  inherited;
  with GetWriter do begin
    WriteBOF;
    WriteHeader;
    fti := TRTFFontTableItem.Create(0, 'nil', FOptions.CaptionStyle.Font.Name);
    AddFont(fti);
    fti := TRTFFontTableItem.Create(1, 'nil', FOptions.DataStyle.Font.Name);
    AddFont(fti);
    WriteFontTable;
    cti := TRTFColorTableItem.Create(clBlack);
    AddColor(cti);
    WriteColorTable;

    SetFont(FOptions.DataStyle.Font, true, FontStr);

    if Options.PageOrientation = poLandscape then begin
      WriteLn('\landscape');
      WriteLn('\paperw16838');
      WriteLn('\paperh11906');
    end
    else begin
      WriteLn('\paperw11906');
      WriteLn('\paperh16838');
    end;

    Style := TrtfStyle.Create(nil);
    try
      Style.Assign(FOptions.HeaderStyle);
      if Assigned(FOnGetHeaderStyle) then FOnGetHeaderStyle(Self, Style);

      StyleToStrs(Style, AlignStr, FontStr, ColorStr, AttrStr,
        BackgroundStr, HighlightStr);
    finally
      Style.Free;
    end;

    if BackgroundStr <> EmptyStr then
      BackgroundStr := BackgroundStr + ' ';

    if Self.Header.Count > 0 then begin
      WriteLn('{' + AlignStr + BackgroundStr);
      try
        for i := 0 to Self.Header.Count - 1 do begin
          FormatStr := FontStr + ColorStr + AttrStr;
          if FormatStr <> EmptyStr then
            FormatStr := FormatStr + ' ';
          Write('{' + HighlightStr + FormatStr);
          {$IFDEF QE_UNICODE}
            NewResult := '';
            TempStr := NormalString(Self.Header[i]);
            stlen := 0;
            //finding complete string length
            for j := 1 to Length(TempStr) do
            begin
              Code := Word(TempStr[j]);
              if not (Code in [Word(#13), Word(#10), Word('\')]) then
                stlen := stlen + 3 + Length(IntToStr(Code))
              else
                stlen := stlen + 1;
            end;
            SetLength(NewResult, stlen);
            stlen := 1;
            //Changing to unicode
            for j := 1 to Length(TempStr) do
            begin
              Code := Word(TempStr[j]);
              if not (Code in [Word(#13), Word(#10), Word('\')]) then
              begin
                TempCodeString := IntToStr(Code);
                NewResult[stlen] := '\';
                NewResult[stlen + 1] := 'u';
                for k := 1 to Length(TempCodeString) do
                  NewResult[stlen + 1 + k] := TempCodeString[k];
                NewResult[stlen + 2 + Length(TempCodeString)] := '?';
                stlen := stlen + 3 + Length(TempCodeString);
              end
              else
              begin
                NewResult[stlen] := TempStr[j];
                stlen := stlen + 1;
              end;
            end;
            Write(NewResult);
          {$ELSE}
            Write(NormalString(Self.Header[i]));
          {$ENDIF}
          WriteLn('}');
          WritePara;
        end;
      finally
        WriteLn('}');
      end;
    end;

    WritePara;
    WriteLn('\trowd\trql\trgaph0\trleft36');
    CurRM := 36;
    {$IFDEF WIN32}
     {$IFNDEF NOGUI}
     N := GetDisplayTextWidth('X', Options.CaptionStyle.Font);
     {$ELSE}
     N := XL;
     {$ENDIF}
    {$ELSE}
    N := XL;
    {$ENDIF}
    for i := 0 to  Columns.Count - 1 do
    begin
      CurRM := CurRM + Columns[i].Width * N * 15 + 10;
      WriteLn('\clbrdrl\brdrth \clbrdrr\brdrth \clbrdrt\brdrth \clbrdrb\brdrth');
      WriteLn('\cellx' + IntToStr(CurRM));
    end;
  end;
end;

procedure TQExport4RTF.BeforeExport;
var
  FontStr: string;
begin
  GetWriter.SetFont(FOptions.DataStyle.Font, true, FontStr);
end;

function TQExport4RTF.GetColCaption(Index: integer): String;
var
  AlignStr, FontStr, ColorStr, AttrStr,
  BackgroundStr, HighlightStr, FormatStr: string;
  i: integer;
  Style: TrtfStyle;
  ColAlign: TQExportColAlign;
  {$IFDEF QE_UNICODE}
  TempStr, NewResult, TempCodeString: WideString;
  Code: Word;
  stlen, j: Integer;
  {$ENDIF}
begin
  Result := inherited GetColCaption(Index);

  case FOptions.CaptionStyle.Alignment of
    talCenter: ColAlign := ecaCenter;
    talRight: ColAlign := ecaRight;
    else ColAlign := ecaLeft;
  end;
  if FOptions.CaptionAligns.Count > 0 then begin
    i := FOptions.CaptionAligns.IndexOfName(Columns[Index].Name);
    if (i > -1) and
       (Length(FOptions.CaptionAligns.Values[Columns[Index].Name]) > 0) then begin
      case AnsiUpperCase(FOptions.CaptionAligns.Values[Columns[Index].Name])[1] of
        'C': ColAlign := ecaCenter;
        'R': ColAlign := ecaRight;
        else ColAlign := ecaLeft;
      end;
    end;
  end;

  Style := TrtfStyle.Create(nil);
  try
    Style.Assign(FOptions.CaptionStyle);