From 824981797878b066d1f7b5f7ba4f69758163989d Mon Sep 17 00:00:00 2001 From: jesus Date: Thu, 10 Dec 2009 22:14:45 +0000 Subject: [PATCH] LazReport, implemented parameters for export filters, CSV exporter now output quoted values and is not based on object's interpolated position git-svn-id: trunk@23076 - --- .gitattributes | 1 + components/lazreport/source/lazreport.lpk | 6 +- components/lazreport/source/lazreport.pas | 6 +- components/lazreport/source/lr_class.pas | 51 +++++++- components/lazreport/source/lr_e_csv.pas | 151 +++++++++++++++------- components/lazreport/source/lr_e_gen.pas | 127 ++++++++++++++++++ components/lazreport/source/lr_e_txt.pas | 32 ++++- components/lazreport/source/lr_utils.pas | 27 ++++ 8 files changed, 341 insertions(+), 60 deletions(-) create mode 100644 components/lazreport/source/lr_e_gen.pas diff --git a/.gitattributes b/.gitattributes index 34d7613cb2..63e9235298 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1365,6 +1365,7 @@ components/lazreport/source/lr_dsopt.lfm svneol=native#text/plain components/lazreport/source/lr_dsopt.lrs svneol=native#text/pascal components/lazreport/source/lr_dsopt.pas svneol=native#text/pascal components/lazreport/source/lr_e_csv.pas svneol=native#text/pascal +components/lazreport/source/lr_e_gen.pas svneol=native#text/pascal components/lazreport/source/lr_e_htm.pas svneol=native#text/pascal components/lazreport/source/lr_e_txt.pas svneol=native#text/pascal components/lazreport/source/lr_edit.lfm svneol=native#text/plain diff --git a/components/lazreport/source/lazreport.lpk b/components/lazreport/source/lazreport.lpk index e4fe1e10ca..1579451ca0 100644 --- a/components/lazreport/source/lazreport.lpk +++ b/components/lazreport/source/lazreport.lpk @@ -27,7 +27,7 @@ Lazarus Port: Olivier Guilbaud, Jesus Reyes A. See license.txt and license-lazreport.txt for details. "/> - + @@ -285,6 +285,10 @@ See license.txt and license-lazreport.txt for details. + + + + diff --git a/components/lazreport/source/lazreport.pas b/components/lazreport/source/lazreport.pas index f49bfe6c9f..ca0ba47793 100644 --- a/components/lazreport/source/lazreport.pas +++ b/components/lazreport/source/lazreport.pas @@ -1,5 +1,5 @@ -{ This file was automatically created by Lazarus. do not edit! - This source is only used to compile and install the package. +{ Este archivo ha sido creado automáticamente por Lazarus. ¡No lo edite! + Este fuente se utiliza sólo para compilar e instalar el paquete. } unit lazreport; @@ -11,7 +11,7 @@ uses LR_PGrid, LR_View, lr_expres, lr_funct_editor_unit, lr_funct_editor_unit1, LR_Prntr, LR_Edit, LR_Pars, LR_fmted, LR_Const, LR_pgopt, LR_Dopt, LR_GEdit, LR_Utils, LR_GrpEd, lr_propedit, LR_progr, LR_IFlds, SysUtilsAdds, LR_RRect, - LR_Shape, LR_E_TXT, LR_E_HTM, LR_E_CSV, LazarusPackageIntf; + LR_Shape, LR_E_TXT, LR_E_HTM, LR_E_CSV, lr_e_gen, LazarusPackageIntf; implementation diff --git a/components/lazreport/source/lr_class.pas b/components/lazreport/source/lr_class.pas index 28eb02d49c..da0586b38e 100644 --- a/components/lazreport/source/lr_class.pas +++ b/components/lazreport/source/lr_class.pas @@ -18,9 +18,7 @@ uses SysUtils, Classes, Controls, FileUtil, Forms, ComCtrls, Dialogs, Menus, Variants, DB,Graphics,Printers,osPrinters,XMLConf, - - LCLType,LCLIntf,TypInfo,LCLProc, - SysUtilsAdds, + LCLType,LCLIntf,TypInfo,LCLProc, SysUtilsAdds, LR_View, LR_Pars, LR_Intrp, LR_DSet, LR_DBSet, LR_DBRel, LR_Const; const @@ -29,13 +27,17 @@ const flWordWrap = 2; flWordBreak = 4; flAutoSize = 8; - flHideDuplicates = 16; + flHideDuplicates = $10; + flStartRecord = $20; + flEndRecord = $40; + flBandNewPageAfter = 2; flBandPrintifSubsetEmpty = 4; flBandPageBreak = 8; flBandOnFirstPage = $10; flBandOnLastPage = $20; flBandRepeatHeader = $40; + flPictCenter = 2; flPictRatio = 4; flWantHook = $8000; @@ -66,6 +68,7 @@ type btOverlay, btColumnHeader, btColumnFooter, btGroupHeader, btGroupFooter, btCrossHeader, btCrossData, btCrossFooter, btNone); + TfrBandTypes = set of TfrBandType; TfrDataSetPosition = (psLocal, psGlobal); TfrValueType = (vtNotAssigned, vtDBField, vtOther, vtFRVar); TfrPageMode = (pmNormal, pmBuildList); @@ -796,11 +799,20 @@ type property Count: Integer read GetCount; end; + { TfrExportFilter } + + TExportFilterSetup = procedure(Sender: TfrExportFilter) of object; + TfrExportFilter = class(TObject) + private + FOnSetup: TExportFilterSetup; + FBandTypes: TfrBandTypes; + FUseProgressBar: boolean; protected Stream: TStream; Lines: TFpList; procedure ClearLines; + procedure Setup; virtual; public constructor Create(AStream: TStream); virtual; destructor Destroy; override; @@ -810,6 +822,10 @@ type procedure OnEndPage; virtual; procedure OnData(x, y: Integer; View: TfrView); virtual; procedure OnText(x, y: Integer; const text: String; View: TfrView); virtual; + + property BandTypes: TfrBandTypes read FBandTypes write FBandTypes; + property UseProgressbar: boolean read FUseProgressBar write FUseProgressBar; + property OnSetup: TExportFilterSetup read FOnSetup write FOnSetup; end; TfrExportFilterClass = class of TfrExportFilter; @@ -821,6 +837,7 @@ type TfrReport = class(TComponent) private FDataType: TfrDataType; + FOnExportFilterSetup: TExportFilterSetup; FPages: TfrPages; FEMFPages: TfrEMFPages; FReportAutor: string; @@ -985,6 +1002,7 @@ type property OnBeginColumn: TBeginColumnEvent read FOnBeginColumn write FOnBeginColumn; property OnPrintColumn: TPrintColumnEvent read FOnPrintColumn write FOnPrintColumn; property OnManualBuild: TManualBuildEvent read FOnManualBuild write FOnManualBuild; + property OnExportFilterSetup: TExportFilterSetup read FOnExportFilterSetup write FOnExportFilterSetup; end; TfrCompositeReport = class(TfrReport) @@ -1093,6 +1111,7 @@ type Text: String[255]; FontName: String[32]; FontSize, FontStyle, FontColor, FontCharset, FillColor: Integer; + Typ: Byte; end; TfrAddInObjectInfo = record @@ -4682,6 +4701,11 @@ begin DoSubReports; break; end; + + t.Flags:=t.Flags and not (flStartRecord or flEndRecord); + if i=0 then t.Flags := t.Flags or flStartRecord; + if i=Objects.Count-1 then t.Flags := t.Flags or flEndRecord; + DrawObject(t); if MasterReport.Terminated then break; end; @@ -8280,11 +8304,18 @@ var begin ExportStream := TFileStream.Create(UTF8ToSys(aFileName), fmCreate); FCurrentFilter := FilterClass.Create(ExportStream); - FCurrentFilter.OnBeginDoc; CurReport := Self; MasterReport := Self; + + FCurrentFilter.OnSetup:=CurReport.OnExportFilterSetup; + + FCurrentFilter.Setup; + FCurrentFilter.OnBeginDoc; + SavedAllPages := EMFPages.Count; + + if FCurrentFilter.UseProgressbar then with frProgressForm do begin s := sReportPreparing; @@ -8296,7 +8327,8 @@ begin Label1.Caption := FirstCaption + ' 1'; OnBeforeModal := @ExportBeforeModal; Show_Modal(Self); - end; + end else + ExportBeforeModal(nil); FreeAndNil(FCurrentFilter); ExportStream.Free; @@ -8925,6 +8957,7 @@ begin inherited Create; Stream := AStream; Lines := TFpList.Create; + FBandTypes := [btMasterHeader, btMasterData]; end; destructor TfrExportFilter.Destroy; @@ -8952,6 +8985,12 @@ begin Lines.Clear; end; +procedure TfrExportFilter.Setup; +begin + if assigned(FOnSetup) then + FOnSetup(Self); +end; + procedure TfrExportFilter.OnBeginDoc; begin // abstract method diff --git a/components/lazreport/source/lr_e_csv.pas b/components/lazreport/source/lr_e_csv.pas index 87e03b7d39..9a363b9bfe 100644 --- a/components/lazreport/source/lr_e_csv.pas +++ b/components/lazreport/source/lr_e_csv.pas @@ -17,10 +17,12 @@ interface uses Classes, SysUtils, LResources, Graphics,GraphType, Controls, Forms, Dialogs,LR_E_TXT, - LCLType,LCLIntf,LR_Class; + LCLType,LCLIntf,lr_utils,lr_class; type + TfrQuoteType = (qtNone, qtQuoteChar); + TfrCSVExport = class(TComponent) public Constructor Create(aOwner : TComponent); override; @@ -30,13 +32,22 @@ type TfrCSVExportFilter = class(TfrTextExportFilter) private - FIntervals: TFPList; + FQuoteChar: TUTF8Char; + FQuoteType: TfrQuoteType; + FSeparator: TUTF8Char; + FCurY : Integer; + protected + procedure GetUsedFont; override; public constructor Create(AStream: TStream); override; - destructor Destroy; override; procedure OnBeginPage; override; procedure OnEndPage; override; + procedure OnData(x, y: Integer; View: TfrView); override; procedure OnText(X, Y: Integer; const Text: String; View: TfrView); override; + + property QuoteChar: TUTF8Char read FQuoteChar write FQuoteChar; + property QuoteType: TfrQuoteType read FQuoteType write FQuoteType; + property Separator: TUTF8Char read FSeparator write FSeparator; end; @@ -47,22 +58,23 @@ uses LR_Const; const FIELD_GRAIN = 32; // granularity of fields when converting pixel positions +procedure TfrCSVExportFilter.GetUsedFont; +begin + // never ask usedfont dialog in CSV exporter +end; + constructor TfrCSVExportFilter.Create(AStream: TStream); begin inherited Create(AStream); - FIntervals := TFPList.Create; -end; - -destructor TfrCSVExportFilter.Destroy; -begin - FIntervals.Free; - inherited destroy; + FQuoteType := qtQuoteChar; + FQuoteChar := '"'; + FSeparator := ';'; end; procedure TfrCSVExportFilter.OnBeginPage; begin inherited OnBeginPage; - FIntervals.Clear; + FCurY := -1; end; function CompareIntervals(Item1, Item2: Pointer): Integer; @@ -72,10 +84,25 @@ end; procedure TfrCSVExportFilter.OnEndPage; var - i, j, k, n, tc1, tc2: Integer; - MaxCols: Integer; - p, q: PfrTextRec; - s,str: String; + i,n: Integer; + p: PfrTextRec; + s: String; + + procedure AddStr(aStr: string); + begin + if QuoteType=qtNone then begin + if s = '' then + s := aStr + else + s := aStr + Separator + aStr; + end else begin + if s = '' then + s := UTF8Quotedstr(aStr, QuoteChar) + else + s := s + Separator + UTF8Quotedstr(aStr, QuoteChar); + end; + end; + begin n := Lines.Count - 1; @@ -85,47 +112,83 @@ begin Dec(n); end; - if FIntervals.Count = 0 then - exit; - - FIntervals.Sort(@CompareIntervals); - for i := 0 to n do begin - p := PfrTextRec(Lines[i]); - if p = nil then - continue; - s := ''; - for j := 0 to FIntervals.Count-1 do - begin - - if (P <> nil) and ((P^.X div FIELD_GRAIN) = PtrInt(FIntervals[j])) then - begin - Str := p^.Text; - p := p^.Next; - end else - Str := ''; - - if j=0 then - s := str - else - s := s + ';' + str; - + p := PfrTextRec(Lines[i]); + while p<>nil do begin + if P^.Typ in [gtMemo,gtAddin] then + AddStr(P^.Text); + p := p^.Next; end; - s := s + LineEnding; Stream.Write(s[1], Length(s)); end; end; +procedure TfrCSVExportFilter.OnData(x, y: Integer; View: TfrView); +var + p, p1, p2: PfrTextRec; + i: Integer; + s: string; +begin + + if (View = nil) or not (View.ParentBandType in BandTypes) then + exit; + if View.Flags and flStartRecord<>0 then + Inc(FCurY); + + p1 := PfrTextRec(Lines[FCurY]); + + GetMem(p, SizeOf(TfrTextRec)); + FillChar(p^, SizeOf(TfrTextRec), 0); + p^.Next := nil; + p^.X := X; + P^.Typ := View.Typ; + p^.Text := ''; + for i:=0 to View.Memo.Count-1 do begin + P^.Text := P^.Text + View.Memo[i]; + if i<>View.Memo.Count-1 then + P^.Text := P^.Text + LineEnding; + end; + if View is TfrMemoView then + with View as TfrMemoView do + begin + p^.FontName := Font.Name; + p^.FontSize := Font.Size; + p^.FontStyle := frGetFontStyle(Font.Style); + p^.FontColor := Font.Color; + p^.FontCharset := Font.Charset; + end; + p^.FillColor := View.FillColor; + + if p1 = nil then + Lines[FCurY] := TObject(p) + else + begin + p2 := p1; + while (p1 <> nil) and (p1^.X < p^.X) do + begin + p2 := p1; + p1 := p1^.Next; + end; + if p2 <> p1 then + begin + p2^.Next := p; + p^.Next := p1; + end + else + begin + Lines[FCurY] := TObject(p); + p^.Next := p1; + end; + end; +end; + procedure TfrCSVExportFilter.OnText(X, Y: Integer; const Text: String; View: TfrView); begin - inherited OnText(X, Y, Text, View); - x := x div FIELD_GRAIN; - if FIntervals.IndexOf(pointer(ptrint(x)))<0 then - FIntervals.Add(pointer(ptrint(x))); + // end; constructor TfrCSVExport.Create(aOwner: TComponent); diff --git a/components/lazreport/source/lr_e_gen.pas b/components/lazreport/source/lr_e_gen.pas new file mode 100644 index 0000000000..cbe136297c --- /dev/null +++ b/components/lazreport/source/lr_e_gen.pas @@ -0,0 +1,127 @@ +unit lr_e_gen; + +interface + +{$I lr_vers.inc} + +uses + Classes, SysUtils, LResources, + Graphics,GraphType, Controls, Forms, Dialogs,LR_E_TXT, + LCLType,LCLIntf,LR_Class, LCLProc; + +type + + { TfrDBGExport } + + TfrDBGExport = class(TComponent) + public + Constructor Create(aOwner : TComponent); override; + end; + + { TfrDBGExportFilter } + + TfrDBGExportFilter = class(TfrExportFilter) + public + constructor Create(AStream: TStream); override; + destructor Destroy; override; + procedure OnBeginPage; override; + procedure OnEndPage; override; + procedure OnData(x, y: Integer; View: TfrView); override; + procedure OnText(X, Y: Integer; const Text: String; View: TfrView); override; + end; + +implementation + +{ TfrDBGExport } + +constructor TfrDBGExport.Create(aOwner: TComponent); +begin + inherited Create(aOwner); + frRegisterExportFilter(TfrDBGExportFilter, 'Debug Export Filter (*.dbg)', '*.dbg'); +end; + +{ TfrDBGExportFilter } + +constructor TfrDBGExportFilter.Create(AStream: TStream); +begin + inherited Create(AStream); + WriteLn('DebugExportFilter: Created'); +end; + +destructor TfrDBGExportFilter.Destroy; +begin + inherited Destroy; + WriteLn('DebugExportFilter: Destroyed'); +end; + +procedure TfrDBGExportFilter.OnBeginPage; +begin + WriteLn(' DebugExportFilter: OnBeginPage'); +end; + +procedure TfrDBGExportFilter.OnEndPage; +begin + WriteLn(' DebugExportFilter: OnEndPage'); +end; + +function TypToStr(Typ:Integer):string; +begin + case Typ of + gtMemo : result := 'gtMemo'; + gtPicture : result := 'gtPicture'; + gtBand : result := 'gtBand'; + gtSubReport : result := 'gtSubReport'; + gtLine : result := 'gtLine'; + gtAddIn : result := 'gtAddIn'; + else result := 'gt?????????'; + end; +end; +function BandToStr(Bt: TfrBandType): string; +begin + case bt of + btReportTitle : result := 'btReportTitle'; + btReportSummary : result := 'btReportSummary'; + btPageHeader : result := 'btPageHeader'; + btPageFooter : result := 'btPageFooter'; + btMasterHeader : result := 'btMasterHeader'; + btMasterData : result := 'btMasterData'; + btMasterFooter : result := 'btMasterFooter'; + btDetailHeader : result := 'btDetailHeader'; + btDetailData : result := 'btDetailData'; + btDetailFooter : result := 'btDetailFooter'; + btSubDetailHeader : result := 'btSubDetailHeader'; + btSubDetailData : result := 'btSubDetailData'; + btSubDetailFooter : result := 'btSubDetailFooter'; + btOverlay : result := 'btOverlay'; + btColumnHeader : result := 'btColumnHeader'; + btColumnFooter : result := 'btColumnFooter'; + btGroupHeader : result := 'btGroupHeader'; + btGroupFooter : result := 'btGroupFooter'; + btCrossHeader : result := 'btCrossHeader'; + btCrossData : result := 'btCrossData'; + btCrossFooter : result := 'btCrossFooter'; + btNone : result := 'btNone'; + else + result := 'Band?????'; + end; + +end; + +procedure TfrDBGExportFilter.OnData(x, y: Integer; View: TfrView); +begin + Write(' OnData ['); + if View.Flags and flStartRecord <>0 then Write(' StartRecord'); + if View.Flags and flEndRecord <>0 then Write(' EndRecord'); + Write('] X=',x,' Y=',Y,' View=',View.Name,':',View.ClassName,' Typ=',TypToStr(View.Typ)); + Write(' ParentBand=',BandToStr(View.ParentBandType)); + Writeln(' Memo=',dbgstr(View.Memo.Text)); +end; + +procedure TfrDBGExportFilter.OnText(X, Y: Integer; const Text: String; + View: TfrView); +begin + writeLn(' OnText X=',X,' Y=',Y,' View=',View.Name,':',View.ClassName,' text=',dbgstr(Text)); +end; + +end. + diff --git a/components/lazreport/source/lr_e_txt.pas b/components/lazreport/source/lr_e_txt.pas index dd3feb57c4..150aaef8dd 100644 --- a/components/lazreport/source/lr_e_txt.pas +++ b/components/lazreport/source/lr_e_txt.pas @@ -28,12 +28,21 @@ type Constructor Create(aOwner : TComponent); override; end; + { TfrTextExportFilter } + TfrTextExportFilter = class(TfrExportFilter) + private + FUsedFont: Integer; + protected + procedure GetUsedFont; virtual; + procedure Setup; override; public constructor Create(AStream: TStream); override; procedure OnEndPage; override; procedure OnBeginPage; override; procedure OnText(X, Y: Integer; const Text: String; View: TfrView); override; + + property UsedFont: integer read FUsedFont write FUsedFont; end; @@ -42,17 +51,28 @@ implementation uses LR_Utils, LR_Const; -var - UsedFont: Integer = 16; - -constructor TfrTextExportFilter.Create(AStream: TStream); +procedure TfrTextExportFilter.GetUsedFont; var s: String; n: Integer; +begin + s := InputBox(sFilter, sFilterParam, '10'); + Val(s, FUsedFont, n); + if n<>0 then + FUsedFont := 10; +end; + +procedure TfrTextExportFilter.Setup; +begin + inherited Setup; + if FUsedFont<=0 then + GetUsedFont; +end; + +constructor TfrTextExportFilter.Create(AStream: TStream); begin inherited; - s := InputBox(sFilter, sFilterParam, '16'); - Val(s, UsedFont, n); + FUsedFont := 10; end; procedure TfrTextExportFilter.OnEndPage; diff --git a/components/lazreport/source/lr_utils.pas b/components/lazreport/source/lr_utils.pas index 2243a11238..739ed09ab4 100644 --- a/components/lazreport/source/lr_utils.pas +++ b/components/lazreport/source/lr_utils.pas @@ -59,6 +59,7 @@ function UTF8Char(S:string; index:Integer; Desc:string): TUTF8Char; function UTF8Range(S:string; index,count:Integer; Desc:String):string; function UTF8Index(S:string; index:integer; desc:string): Integer; function UTF8CharIn(ch:TUTF8Char; const arrstr:array of string): boolean; +function UTF8QuotedStr(s:string; Quote: TUTF8Char; desc:string=''): string; implementation @@ -628,4 +629,30 @@ begin end; end; +// converted from FPC AnsiQuotedStr() +function UTF8QuotedStr(s: string; Quote: TUTF8Char; desc:string=''): string; +var + i, j, count: integer; +begin + result := '' + Quote; + if desc='' then + count := UTF8Desc(s, desc) + else + count := length(s); + + i := 0; + j := 0; + while i < count do begin + i := i + 1; + if UTF8Char(s,i,desc) = Quote then begin + result := result + UTF8Range(S, 1 + j, i - j, desc) + Quote; + j := i; + end; + end; + + if i <> j then + result := result + UTF8Range(S, 1 + j, i - j, desc); + result := result + Quote; +end ; + end.