frxexportxml.pas

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

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

unit frxExportXML;

interface

{$I frx.inc}

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

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

  TfrxXMLExport = class(TfrxCustomExportFilter)
  private
    FExportPageBreaks: Boolean;
    FExportStyles: Boolean;
    FFirstPage: Boolean;
    FMatrix: TfrxIEMatrix;
    FOpenExcelAfterExport: Boolean;
    FPageBottom: Extended;
    FPageLeft: Extended;
    FPageRight: Extended;
    FPageTop: Extended;
    FPageOrientation: TPrinterOrientation;
    FProgress: TfrxProgress;
    FShowProgress: Boolean;
    FWysiwyg: Boolean;
    FBackground: Boolean;
    FCreator: String;
    procedure ExportPage(Stream: TStream);
    function ChangeReturns(const Str: String): String;
    function TruncReturns(const Str: String): String;
    function IsDigits(const Str: String): Boolean;
  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 ExportStyles: Boolean read FExportStyles write FExportStyles default True;
    property ExportPageBreaks: Boolean read FExportPageBreaks write FExportPageBreaks default True;
    property OpenExcelAfterExport: Boolean read FOpenExcelAfterExport
      write FOpenExcelAfterExport default False;
    property ShowProgress: Boolean read FShowProgress write FShowProgress;
    property Wysiwyg: Boolean read FWysiwyg write FWysiwyg default True;
    property Background: Boolean read FBackground write FBackground default False;
    property Creator: String read FCreator write FCreator;
  end;


implementation

uses frxUtils, frxRes, frxrcExports;

{$R *.dfm}

const
  Xdivider = 1.375;
  Ydivider = 1.375;
  MargDiv = 26.3;
  XLMaxHeight = 409;


{ TfrxXMLExport }

constructor TfrxXMLExport.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FExportPageBreaks := True;
  FExportStyles := True;
  FShowProgress := True;
  FWysiwyg := True;
  FBackground := True;
  FCreator := 'FastReport'#174;
end;

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

function TfrxXMLExport.TruncReturns(const Str: String): String;
begin
  Result := Str;
  if Copy(Result, Length(Result) - 1, 2) = #13#10 then
    Delete(Result, Length(Result) - 1, 2);
end;

function TfrxXMLExport.ChangeReturns(const Str: String): String;
var
  i: Integer;
  s: String;
begin
  Result := Str;
  Result := StringReplace(Result, '&', '&', [rfReplaceAll]);
  i := 1;
  while i <= Length(Result) do
    if Result[i] in ['0'..'9'] then
    begin
      s := '&#' + IntToStr(StrToInt(Result[i]) + 48);
      Delete(Result, i, 1);
      Insert(s, Result, i);
      Inc(i, 4);
    end
    else
      Inc(i);
  Result := StringReplace(Result, #13#10, '&#10', [rfReplaceAll]);
  Result := StringReplace(Result, '"', '&quot;', [rfReplaceAll]);
  Result := StringReplace(Result, '<', '&lt;', [rfReplaceAll]);
  Result := StringReplace(Result, '>', '&gt;', [rfReplaceAll]);
end;

procedure TfrxXMLExport.ExportPage(Stream: TStream);
var
  i, x, y, dx, dy, fx, fy, Page: Integer;
  dcol, drow: Extended;
  s, sb, si, su: String;
  Vert, Horiz: String;
  obj: TfrxIEMObject;
  EStyle: TfrxIEMStyle;
  St: String;
  OldSeparator: Char;
  PageBreak: TStringList;

  procedure WriteExpLn(const str: String);
  begin
    if Length(str) > 0 then
      Stream.Write(str[1], Length(str));
    Stream.Write(#13#10, 2);
  end;

  procedure AlignFR2AlignExcel(HAlign: TfrxHAlign; VAlign: TfrxVAlign;
    var AlignH, AlignV: String);
  begin
    if HAlign = haLeft then
      AlignH := 'Left'
    else if HAlign = haRight then
      AlignH := 'Right'
    else if HAlign = haCenter then
      AlignH := 'Center'
    else if HAlign = haBlock then
      AlignH := 'Justify'
    else
      AlignH := '';
    if VAlign = vaTop then
      AlignV := 'Top'
    else if VAlign = vaBottom then
      AlignV := 'Bottom'
    else if VAlign = vaCenter then
      AlignV := 'Center'
    else
      AlignV := '';
  end;

begin
  PageBreak := TStringList.Create;
  if FShowProgress then
  begin
    FProgress := TfrxProgress.Create(nil);
    FProgress.Execute(FMatrix.PagesCount, 'Exporting pages', True, True);
  end;

  WriteExpLn('<?xml version="1.0"?>');
  WriteExpLn('<?mso-application progid="Excel.Sheet"?>');
  WriteExpLn('<?fr-application created="' + UTF8Encode(FCreator) + '"?>');
  WriteExpLn('<?fr-application homesite="http://www.fast-report.com"?>');
  WriteExpLn('<Workbook xmlns="urn:schemas-microsoft-com:office:spreadsheet"');
  WriteExpLn(' xmlns:o="urn:schemas-microsoft-com:office:office"');
  WriteExpLn(' xmlns:x="urn:schemas-microsoft-com:office:excel"');
  WriteExpLn(' xmlns:ss="urn:schemas-microsoft-com:office:spreadsheet"');
  WriteExpLn(' xmlns:html="http://www.w3.org/TR/REC-html40">');
  WriteExpLn('<DocumentProperties xmlns="urn:schemas-microsoft-com:office:office">');
  WriteExpLn('<Title>' + UTF8Encode(Report.ReportOptions.Name) + '</Title>');
  WriteExpLn('<Author>' + UTF8Encode(Report.ReportOptions.Author) + '</Author>');
  WriteExpLn('<Created>' + DateToStr(Date) + 'T' + TimeToStr(Time) + 'Z</Created>');
  WriteExpLn('<Version>' + UTF8Encode(Report.ReportOptions.VersionMajor) + '.' +
    UTF8Encode(Report.ReportOptions.VersionMinor) + '.' +
    UTF8Encode(Report.ReportOptions.VersionRelease) + '.' +
    UTF8Encode(Report.ReportOptions.VersionBuild) + '</Version>');
  WriteExpLn('</DocumentProperties>');
  WriteExpLn('<ExcelWorkbook xmlns="urn:schemas-microsoft-com:office:excel">');
  WriteExpLn('<ProtectStructure>False</ProtectStructure>');
  WriteExpLn('<ProtectWindows>False</ProtectWindows>');
  WriteExpLn('</ExcelWorkbook>');

  if FExportStyles then
  begin
    WriteExpLn('<Styles>');
    for x := 0 to FMatrix.StylesCount - 1 do
    begin
      EStyle := FMatrix.GetStyleById(x);
      s := 's' + IntToStr(x);
      WriteExpLn('<Style ss:ID="'+s+'">');
      if fsBold in EStyle.Font.Style then
        sb := ' ss:Bold="1"'
      else
        sb := '';
      if fsItalic in EStyle.Font.Style then
        si := ' ss:Italic="1"'
      else
        si := '';
      if fsUnderline in EStyle.Font.Style then
        su := ' ss:Underline="Single"'
      else
        su := '';
      WriteExpLn('<Font '+
        'ss:FontName="' + EStyle.Font.Name + '" '+
        'ss:Size="' + IntToStr(EStyle.Font.Size) + '" ' +
        'ss:Color="' + HTMLRGBColor(EStyle.Font.Color) + '"' + sb + si + su + '/>');
      WriteExpLn('<Interior ss:Color="' + HTMLRGBColor(EStyle.Color) +
        '" ss:Pattern="Solid"/>');
      AlignFR2AlignExcel(EStyle.HAlign, EStyle.VAlign, Horiz, Vert);
      if (EStyle.Rotation > 0) and (EStyle.Rotation <= 90) then
        s := 'ss:Rotate="' + IntToStr(EStyle.Rotation) + '"'
      else  if (EStyle.Rotation < 360) and (EStyle.Rotation >= 270) then
        s := 'ss:Rotate="' + IntToStr(EStyle.Rotation - 360) + '"'
      else
        s := '';
      si := '" ss:WrapText="1" ';
      WriteExpLn('<Alignment ss:Horizontal="' + Horiz + '" ss:Vertical="' + Vert + si + s +'/>');

      WriteExpLn('<Borders>');
      if EStyle.FrameWidth > 1 then
        i := 3
      else
        i := 1;
      s := 'ss:Weight="' + IntToStr(i) + '" ';
      si := 'ss:Color="' + HTMLRGBColor(EStyle.FrameColor) + '" ';
      if (ftLeft in EStyle.FrameTyp) then
        WriteExpLn('<Border ss:Position="Left" ss:LineStyle="Continuous" ' + s + si + '/>');
      if (ftRight in EStyle.FrameTyp) then
        WriteExpLn('<Border ss:Position="Right" ss:LineStyle="Continuous" ' + s + si + '/>');
      if (ftTop in EStyle.FrameTyp) then
        WriteExpLn('<Border ss:Position="Top" ss:LineStyle="Continuous" ' + s + si + '/>');
      if (ftBottom in EStyle.FrameTyp) then
        WriteExpLn('<Border ss:Position="Bottom" ss:LineStyle="Continuous" ' + s + si + '/>');
      WriteExpLn('</Borders>');