{******************************************} { } { FastReport v4.0 } { XML Excel export } { } { Copyright (c) 1998-2008 } { by Alexander Fediachov, } { Fast Reports Inc. } { } {******************************************} { Improved by Bysoev Alexander } { Kanal-B@Yandex.ru } {******************************************} unit FMX.frxExportXML; interface {$I fmx.inc} {$I frx.inc} {$I fmx.inc} uses System.SysUtils, System.Classes, FMX.Types, System.UITypes, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.frxClass, FMX.frxExportMatrix, FMX.frxProgress, fmx.frxImageConverter, System.UIConsts, System.Variants, FMX.Edit, FMX.ListBox, FMX.frxBaseModalForm {$IFDEF DELPHI18} ,FMX.StdCtrls {$ENDIF}; type TfrxSplitToSheet = (ssNotSplit, ssRPages, ssPrintOnPrev, ssRowsCount); TfrxXMLExportDialog = class(TfrxForm) OkB: TButton; CancelB: TButton; SaveDialog1: TSaveDialog; GroupPageRange: TGroupBox; DescrL: TLabel; AllRB: TRadioButton; CurPageRB: TRadioButton; PageNumbersRB: TRadioButton; PageNumbersE: TEdit; GroupQuality: TGroupBox; WCB: TCheckBox; ContinuousCB: TCheckBox; PageBreaksCB: TCheckBox; OpenExcelCB: TCheckBox; BackgrCB: TCheckBox; SplitToSheetGB: TGroupBox; RPagesRB: TRadioButton; PrintOnPrevRB: TRadioButton; RowsCountRB: TRadioButton; ERows: TEdit; NotSplitRB: TRadioButton; procedure FormCreate(Sender: TObject); procedure PageNumbersEChange(Sender: TObject); procedure PageNumbersEKeyDown(Sender: TObject; var Key: Word; var KeyChar: WideChar; Shift: TShiftState); procedure FormKeyDown(Sender: TObject; var Key: Word; var KeyChar: WideChar; Shift: TShiftState); procedure ERowsKeyDown(Sender: TObject; var Key: Word; var KeyChar: WideChar; Shift: TShiftState); procedure ERowsChange(Sender: TObject); end; {$I frxFMX_PlatformsAttribute.inc} 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; FWysiwyg: Boolean; FBackground: Boolean; FCreator: String; FEmptyLines: Boolean; FRowsCount: Integer; FSplit: TfrxSplitToSheet; procedure ExportPage(Stream: TStream); function ChangeReturns(const Str: String): String; function TruncReturns(const Str: WideString): WideString; procedure SetRowsCount(const Value: Integer); 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 Wysiwyg: Boolean read FWysiwyg write FWysiwyg default True; property Background: Boolean read FBackground write FBackground default False; property Creator: string read FCreator write FCreator; property EmptyLines: Boolean read FEmptyLines write FEmptyLines; property SuppressPageHeadersFooters; property OverwritePrompt; property RowsCount: Integer read FRowsCount write SetRowsCount; property Split: TfrxSplitToSheet read FSplit write FSplit; end; implementation uses FMX.frxUtils, FMX.frxUnicodeUtils, FMX.frxRes, FMX.frxrcExports, FMX.frxFMX {$IFDEF MSWINDOWS} , Winapi.ShellAPI, Winapi.Windows {$ENDIF} {$IFDEF LINUX} ,FMUX.Api {$ENDIF} {$IFDEF MACOS} , Posix.Stdlib {$ENDIF}; {$R *.fmx} const Xdivider = 1.6; Ydivider = 1.376; MargDiv = 26.6; XLMaxHeight = 409; { TfrxXMLExport } constructor TfrxXMLExport.Create(AOwner: TComponent); begin inherited; FExportPageBreaks := True; FExportStyles := True; FWysiwyg := True; FBackground := True; FCreator := 'FastReport'; FilterDesc := frxGet(8105); DefaultExt := frxGet(8106); FEmptyLines := True; end; class function TfrxXMLExport.GetDescription: String; begin Result := frxResources.Get('XlsXMLexport'); end; function TfrxXMLExport.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 TfrxXMLExport.ChangeReturns(const Str: string): string; var i: Integer; begin Result := ''; for i := 1 to Length(Str) do case Str[i] of '&': Result := Result + '&'; '"': Result := Result + '"'; '<': Result := Result + '<'; '>': Result := Result + '>'; #13: {skip this symbol}; #0..#12, #14..#31: Result := Result + '&#' + IntToStr(Ord(Str[i])) + ';'; else Result := Result + Str[i] end end; procedure TfrxXMLExport.ExportPage(Stream: TStream); var i, x, y, dx, dy, fx, fy, Page, LastPrevRow: Integer; s: WideString; sb, si, su, ss, decsep, thsep: String; dcol, drow: Extended; Vert, Horiz: String; obj: TfrxIEMObject; IEMPage: TfrxIEMPage; EStyle: TfrxIEMStyle; St, PrevPageName: String; PageBreak: TStringList; function IsDigits(const Str: String): Boolean; var i: Integer; begin Result := True; for i := 1 to Length(Str) do if not((AnsiChar(Str[i]) in ['0'..'9', ',' ,'.' ,'-', ' ', 'ð']) or (Ord(Str[i]) = 160)) then begin Result := False; break; end; end; procedure WriteExpLn(const str: String); var TempStr: AnsiString; begin TempStr := UTF8Encode(str); if Length(TempStr) > 0 then Stream.Write(TempStr[1], Length(TempStr)); Stream.Write(AnsiString(#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; function ConvertFormat(const fstr, fdecsep, fthsep: string): string; var err, p : integer; s: string; begin result := ''; s := ''; if length(fstr)>0 then begin p := pos('.', fstr); if p > 0 then begin s := Copy(fstr, p+1, length(fstr)-p-1); val(s, p ,err); SetLength(s, p); if p>0 then begin s := StringOfChar(Char('0'), p); s := '.' + s; end; end; case fstr[length(fstr)] of 'n': result := '#,##0' + s; 'f': result := '0' + s; 'g': result := '0.##'; 'm': result := '#,##0.00'; // 'm': result := '#,##0.00"ð.;"'; else result := '#,##0.00'; end; end; end; procedure FinishWorkSheet; var i: Integer; begin WriteExpLn(''); WriteExpLn(''); WriteExpLn(''); if FPageOrientation = poLandscape then WriteExpLn(''); WriteExpLn(''); WriteExpLn(''); WriteExpLn(''); if FExportPageBreaks then begin WriteExpLn(''); WriteExpLn(''); for i := 0 to PageBreak.Count - 1 do begin WriteExpLn(''); WriteExpLn('' + PageBreak[i] + ''); WriteExpLn(''); end; WriteExpLn(''); WriteExpLn(''); end; if PageBreak.Count > 0 then LastPrevRow := LastPrevRow + StrToInt(PageBreak[PageBreak.Count - 1]); PageBreak.Clear; WriteExpLn(''); end; procedure StartWorkSheet(SheetName: String); var x:Integer; begin if SheetName = '' then SheetName := 'UnnamedPage_' + IntTostr(Page); WriteExpLn(''); WriteExpLn(''); for x := 1 to FMatrix.Width - 1 do begin dcol := (FMatrix.GetXPosById(x) - FMatrix.GetXPosById(x - 1)) / Xdivider; WriteExpLn(''); end; end; begin PageBreak := TStringList.Create; try if ShowProgress then begin FProgress := TfrxProgress.Create(nil); FProgress.Execute(FMatrix.PagesCount, 'Exporting pages', True, True); end; WriteExpLn(''); WriteExpLn(''); WriteExpLn(''); WriteExpLn(''); WriteExpLn(''); WriteExpLn(''); WriteExpLn('' + Report.ReportOptions.Name + ''); WriteExpLn('' + Report.ReportOptions.Author + ''); WriteExpLn('' + DateToStr(CreationTime) + 'T' + TimeToStr(CreationTime) + 'Z'); WriteExpLn('' + Report.ReportOptions.VersionMajor + '.' + Report.ReportOptions.VersionMinor + '.' + Report.ReportOptions.VersionRelease + '.' + Report.ReportOptions.VersionBuild + ''); WriteExpLn(''); WriteExpLn(''); WriteExpLn('False'); WriteExpLn('False'); WriteExpLn(''); if FExportStyles then begin WriteExpLn(''); for x := 0 to FMatrix.StylesCount - 1 do begin EStyle := FMatrix.GetStyleById(x); s := 's' + IntToStr(x); WriteExpLn(''); end; WriteExpLn(''); end; st := ''; Page := 0; LastPrevRow := 0; IEMPage := FMatrix.IEPages[Page]; if IEMPage <> nil then PrevPageName := IEMPage.PageName; StartWorkSheet(PrevPageName); for y := 0 to FMatrix.Height - 2 do begin drow := (FMatrix.GetYPosById(y + 1) - FMatrix.GetYPosById(y)) / Ydivider; WriteExpLn(''); if (FMatrix.PagesCount > Page) or (FRowsCount > 0) then if (FMatrix.GetYPosById(y) >= FMatrix.GetPageBreak(Page)) or ((FRowsCount <= y + 1 - LastPrevRow) and (FRowsCount > 0)) then begin Inc(Page); PageBreak.Add(IntToStr(y + 1 - LastPrevRow)); if ShowProgress then begin FProgress.Tick; if FProgress.Terminated then break; end; end; for x := 0 to FMatrix.Width - 1 do begin if ShowProgress then if FProgress.Terminated then break; si := ' ss:Index="' + IntToStr(x + 1) + '" '; i := FMatrix.GetCell(x, y); if (i <> -1) then begin Obj := FMatrix.GetObjectById(i); if Obj.Counter = 0 then begin FMatrix.GetObjectPos(i, fx, fy, dx, dy); Obj.Counter := 1; if Obj.IsText then begin if dx > 1 then begin s := 'ss:MergeAcross="' + IntToStr(dx - 1) + '" '; Inc(dx); end else s := ''; if dy > 1 then sb := 'ss:MergeDown="' + IntToStr(dy - 1) + '" ' else sb := ''; if FExportStyles then st := 'ss:StyleID="' + 's' + IntToStr(Obj.StyleIndex) + '" ' else st := ''; WriteExpLn(''); s := TruncReturns(Obj.Memo.Text); if (Obj.Style.DisplayFormat.Kind = fkNumeric) and IsDigits(s) then begin s := StringReplace(s, FormatSettings.ThousandSeparator, '', [rfReplaceAll]); s := StringReplace(s, FormatSettings.CurrencyString, '', [rfReplaceAll]); if Obj.Style.DisplayFormat.DecimalSeparator <> '' then s := StringReplace(s, Obj.Style.DisplayFormat.DecimalSeparator, '.', [rfReplaceAll]) else s := StringReplace(s, FormatSettings.DecimalSeparator, '.', [rfReplaceAll]); s := Trim(s); si := ' ss:Type="Number"'; WriteExpLn('' + s + ''); end else begin si := ' ss:Type="String"'; s := ChangeReturns(s); WriteExpLn('' + s + ''); end; WriteExpLn(''); end; end end else WriteExpLn(''); end; WriteExpLn(''); if (FSplit = ssRowsCount) and ((FRowsCount <= y + 1 - LastPrevRow) and (FRowsCount > 0)) then begin FinishWorkSheet; StartWorkSheet(''); end else begin IEMPage := FMatrix.IEPages[Page]; if IEMPage <> nil then if ((FSplit = ssRPages) and (PrevpageName <> IEMPage.PageName)) or ((FSplit = ssPrintOnPrev) and (PrevpageName <> IEMPage.PageName) and (Page > 0) and not IEMPage.PrintOnPreviousPage) then begin PrevpageName := IEMPage.PageName; FinishWorkSheet; StartWorkSheet(PrevPageName); end; end; end; FinishWorkSheet; WriteExpLn(''); finally PageBreak.Free; end; if ShowProgress then FProgress.Free; end; function TfrxXMLExport.ShowModal: TModalResult; begin if not Assigned(Stream) then begin with TfrxXMLExportDialog.Create(nil) do begin OpenExcelCB.Visible := not SlaveExport; if OverwritePrompt then SaveDialog1.Options := SaveDialog1.Options + [TOpenOption.ofOverwritePrompt]; if SlaveExport then FOpenExcelAfterExport := False; if (FileName = '') and (not SlaveExport) then SaveDialog1.FileName := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(Report.FileName)), SaveDialog1.DefaultExt) else SaveDialog1.FileName := FileName; ContinuousCB.IsChecked := (not EmptyLines) or SuppressPageHeadersFooters; PageBreaksCB.IsChecked := FExportPageBreaks and (not ContinuousCB.IsChecked); PrintOnPrevRB.IsChecked := (FSplit = ssPrintOnPrev); RPagesRB.IsChecked := (FSplit = ssRPages); NotSplitRB.IsChecked := (FSplit = ssNotSplit); if FRowsCount <> 0 then begin ERows.Text := IntToStr(FRowsCount); RowsCountRB.IsChecked := True; end; WCB.IsChecked := FWysiwyg; OpenExcelCB.IsChecked := FOpenExcelAfterExport; BackgrCB.IsChecked := FBackground; if PageNumbers <> '' then begin PageNumbersE.Text := PageNumbers; PageNumbersRB.IsChecked := True; end; Result := ShowModal; PeekLastModalResult; if Result = mrOk then begin PageNumbers := ''; CurPage := False; if CurPageRB.IsChecked then CurPage := True else if PageNumbersRB.IsChecked then PageNumbers := PageNumbersE.Text; if RowsCountRB.IsChecked then begin FSplit := ssRowsCount; FRowsCount := StrToInt(ERows.Text); end else if PrintOnPrevRB.IsChecked then FSplit := ssPrintOnPrev else if RPagesRB.IsChecked then FSplit := ssRPages else FSplit := ssNotSplit; FExportPageBreaks := PageBreaksCB.IsChecked and (not ContinuousCB.IsChecked); EmptyLines := not ContinuousCB.IsChecked; SuppressPageHeadersFooters := ContinuousCB.IsChecked; FWysiwyg := WCB.IsChecked; FOpenExcelAfterExport := OpenExcelCB.IsChecked; FBackground := BackgrCB.IsChecked; if not SlaveExport then begin if DefaultPath <> '' then SaveDialog1.InitialDir := DefaultPath; if SaveDialog1.Execute then FileName := SaveDialog1.FileName else Result := mrCancel; PeekLastModalResult; end end; Free; end; end else Result := mrOk; end; function TfrxXMLExport.Start: Boolean; begin if SlaveExport then begin if Report.FileName <> '' then FileName := ChangeFileExt(GetTemporaryFolder + ExtractFileName(Report.FileName), frxGet(8106)) else FileName := ChangeFileExt(GetTempFile, frxGet(8106)) end; if (FileName <> '') or Assigned(Stream) then begin if (ExtractFilePath(FileName) = '') and (DefaultPath <> '') then FileName := DefaultPath + '\' + FileName; FFirstPage := True; FMatrix := TfrxIEMatrix.Create(UseFileCache, Report.EngineOptions.TempDir); FMatrix.DotMatrix := Report.DotMatrixReport; FMatrix.ShowProgress := ShowProgress; FMatrix.MaxCellHeight := XLMaxHeight * Ydivider; FMatrix.Background := FBackground and FEmptyLines; FMatrix.BackgroundImage := False; FMatrix.Printable := ExportNotPrintable; FMatrix.RichText := True; FMatrix.PlainRich := True; FMatrix.EmptyLines := FEmptyLines; FExportPageBreaks := FExportPageBreaks and FEmptyLines; if FWysiwyg then FMatrix.Inaccuracy := 0.5 else FMatrix.Inaccuracy := 10; FMatrix.DeleteHTMLTags := True; Result := True end else Result := False; end; procedure TfrxXMLExport.StartPage(Page: TfrxReportPage; Index: Integer); begin if FFirstPage then begin FFirstPage := False; FPageLeft := Page.LeftMargin; FPageTop := Page.TopMargin; FPageBottom := Page.BottomMargin; FPageRight := Page.RightMargin; FPageOrientation := Page.Orientation; end; end; procedure TfrxXMLExport.ExportObject(Obj: TfrxComponent); begin if Obj.Page <> nil then Obj.Page.Top := FMatrix.Inaccuracy; if Obj.Name = '_pagebackground' then Exit; if Obj is TfrxView then FMatrix.AddObject(TfrxView(Obj)); end; procedure TfrxXMLExport.FinishPage(Page: TfrxReportPage; Index: Integer); var IEMPage: TfrxIEMPage; begin FMatrix.AddPage(Page.Orientation, Page.Width, Page.Height, Page.LeftMargin, Page.TopMargin, Page.RightMargin, Page.BottomMargin, Page.MirrorMargins, Index); IEMPage := FMatrix.IEPages[Index]; if IEMPage <> nil then with IEMPage do begin PageName := Page.Name; PrintOnPreviousPage := Page.PrintOnPreviousPage; end; end; procedure TfrxXMLExport.Finish; var Exp: TStream; begin FMatrix.Prepare; try if Assigned(Stream) then Exp := Stream else Exp := TFileStream.Create(FileName, fmCreate); try ExportPage(Exp); finally if not Assigned(Stream) then Exp.Free; end; if FOpenExcelAfterExport and (not Assigned(Stream)) then begin {$IFDEF MSWINDOWS} ShellExecute(0, 'open', PChar(FileName), '', '', 5); {$ENDIF} {$IFDEF LINUX} FmuxOpenFile(PChar(FileName)); {$ENDIF} {$IFDEF MACOS} ShellExecute(FileName); {$ENDIF} end; except on e: Exception do case Report.EngineOptions.NewSilentMode of simSilent: Report.Errors.Add(e.Message); simMessageBoxes: frxErrorMsg(e.Message); simReThrow: raise; end; end; FMatrix.Free; end; procedure TfrxXMLExport.SetRowsCount(const Value: Integer); begin FRowsCount := Value; if Value > 0 then FSplit := ssRowsCount else begin FSplit := ssNotSplit; FRowsCount := 0; end; end; { TfrxXMLExportDialog } procedure TfrxXMLExportDialog.FormCreate(Sender: TObject); begin Caption := frxGet(8100); OkB.Text := frxGet(1); CancelB.Text := frxGet(2); GroupPageRange.Text := frxGet(7); AllRB.Text := frxGet(3); CurPageRB.Text := frxGet(4); PageNumbersRB.Text := frxGet(5); DescrL.Text := frxGet(9); GroupQuality.Text := frxGet(8); ContinuousCB.Text := frxGet(8950); PageBreaksCB.Text := frxGet(6); WCB.Text := frxGet(8102); BackgrCB.Text := frxGet(8103); OpenExcelCB.Text := frxGet(8104); SaveDialog1.Filter := frxGet(8105); SaveDialog1.DefaultExt := frxGet(8106); RowsCountRB.Text := frxGet(9000); SplitToSheetGB.Text := frxGet(9001); NotSplitRB.Text := frxGet(9002); RPagesRB.Text := frxGet(9003); PrintOnPrevRB.Text := frxGet(9004); {$IFDEF LINUX} BorderStyleSizeable(Self); {$ENDIF} end; procedure TfrxXMLExportDialog.PageNumbersEChange(Sender: TObject); begin PageNumbersRB.IsChecked := True; end; procedure TfrxXMLExportDialog.PageNumbersEKeyDown(Sender: TObject; var Key: Word; var KeyChar: WideChar; Shift: TShiftState); begin case KeyChar of '0'..'9':; #8, '-', ',':; else key := 0; end; end; procedure TfrxXMLExportDialog.FormKeyDown(Sender: TObject; var Key: Word; var KeyChar: WideChar; Shift: TShiftState); begin if Key = VK_F1 then frxResources.Help(Self); end; procedure TfrxXMLExportDialog.ERowsKeyDown(Sender: TObject; var Key: Word; var KeyChar: WideChar; Shift: TShiftState); begin case KeyChar of '0'..'9', #8:; else key := 0; end; end; procedure TfrxXMLExportDialog.ERowsChange(Sender: TObject); begin RowsCountRB.IsChecked := True; end; end.