1unit fpfixedexport;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8  Classes, SysUtils, db, fpDBExport;
9
10  { TFixedLengthExportFieldItem }
11
12Type
13  TFixedLengthExportFieldItem = Class(TExportFieldItem)
14  private
15    FWidth: Integer;
16    FAlignField: TAlignField;
17  Public
18    Procedure Assign(Source : TPersistent); override;
19  Published
20    Property Width : Integer Read FWidth Write FWidth;
21    Property AlignField: TAlignField Read FAlignField write FAlignField;
22  end;
23
24  { TCustomFixedLengthExporter }
25  TCharMode = (cmANSI,cmUTF8,cmUTF16);
26
27  { TFixedExportFormatSettings }
28
29  TFixedExportFormatSettings = Class (TExportFormatSettings)
30  private
31    FCharMode: TCharMode;
32    FColumnSeparatorSpaceCount: Integer;
33    FHeaderRow: Boolean;
34  Public
35    Procedure Assign(Source: TPersistent); override;
36  Published
37    // Whether or not the file should have a header row with field names
38    Property HeaderRow : Boolean Read FHeaderRow Write FHeaderRow default true;
39    // How to handle Unicode ?
40    Property CharMode : TCharMode Read FCharMode Write FCharMode;
41    // Number of separator spaces between columns. Default 0.
42    Property ColumnSeparatorSpaceCount : Integer Read FColumnSeparatorSpaceCount Write FColumnSeparatorSpaceCount;
43  end;
44
45  TCustomFixedLengthExporter = Class(TCustomFileExporter)
46  Private
47    FCurrentRow : RawByteString;
48    FCurrentRowUnicode : UnicodeString;
49    FSpaces : RawByteString;
50    FSpacesUnicode : UnicodeString;
51    function GetCharMode: TCharMode;
52    function GeTFixedExportFormatSettings: TFixedExportFormatSettings;
53    procedure SetFixedExportFormatSettings(AValue: TFixedExportFormatSettings);
54  Protected
55    function ExportFieldAsUniCodeString(EF: TExportFieldItem; isHeader: Boolean=False): UnicodeString; virtual;
56    procedure ExportFieldAnsi(EF: TExportFieldItem; isHeader: Boolean=False); virtual;
57    procedure ExportFieldUTF16(EF: TExportFieldItem; isHeader: Boolean=False); virtual;
58    procedure ExportFieldUTF8(EF: TExportFieldItem; isHeader: Boolean=False); virtual;
59    Procedure BuildDefaultFieldMap(AMap : TExportFields); override;
60    Function  CreateExportFields : TExportFields; override;
61    Function  CreateFormatSettings: TCustomExportFormatSettings; override;
62    Procedure DoBeforeExecute; override;
63    Procedure DoAfterExecute; override;
64    Procedure DoDataRowStart; override;
65    Procedure ExportField(EF : TExportFieldItem); override;
66    Procedure DoDataRowEnd; override;
67    Procedure DoDataHeader; override;
68    Property CharMode : TCharMode Read GetCharMode;
69    Property FormatSettings : TFixedExportFormatSettings Read GetFixedExportFormatSettings Write SetFixedExportFormatSettings;
70  end;
71
72  TFixedLengthExporter = Class(TCustomFixedLengthExporter)
73  Published
74    Property FileName;
75    Property Dataset;
76    Property ExportFields;
77    Property FromCurrent;
78    Property RestorePosition;
79    Property FormatSettings;
80    Property OnExportRow;
81  end;
82
83Procedure RegisterFixedExportFormat;
84Procedure UnRegisterFixedExportFormat;
85
86Const
87  SFixedLengthExport      = 'Fixed';
88  SFixedLengthExtensions  = '.txt';
89
90Resourcestring
91  SFixedLengthDescription = 'Text file with fixed length records';
92
93
94
95implementation
96
97uses math;
98
99{ TFixedExportFormatSettings }
100
101procedure TFixedExportFormatSettings.Assign(Source: TPersistent);
102begin
103  if (Source is TFixedExportFormatSettings) then
104    begin
105    CharMode:=TFixedExportFormatSettings(Source).CharMode;
106    HeaderRow:=TFixedExportFormatSettings(Source).HeaderRow;
107    ColumnSeparatorSpaceCount:=TFixedExportFormatSettings(Source).ColumnSeparatorSpaceCount;
108    end;
109  inherited Assign(Source);
110end;
111
112{ TFixedLengthExportFieldItem }
113
114procedure TFixedLengthExportFieldItem.Assign(Source: TPersistent);
115
116Var
117  FL : TFixedLengthExportFieldItem;
118
119begin
120  If Source is TFixedLengthExportFieldItem then
121    begin
122    FL:=Source as TFixedLengthExportFieldItem;
123    Width:=FL.Width;
124    AlignField:=FL.AlignFIeld;
125    end;
126  inherited Assign(Source);
127end;
128
129{ TCustomFixedLengthExporter }
130
131
132procedure TCustomFixedLengthExporter.SetFixedExportFormatSettings(AValue: TFixedExportFormatSettings);
133begin
134  Inherited FormatSettings:=AValue;
135end;
136
137function TCustomFixedLengthExporter.GetCharMode: TCharMode;
138begin
139  Result:=FormatSettings.CharMode;
140end;
141
142function TCustomFixedLengthExporter.GeTFixedExportFormatSettings: TFixedExportFormatSettings;
143begin
144  Result:=(Inherited Formatsettings) as TFixedExportFormatSettings;
145end;
146
147procedure TCustomFixedLengthExporter.BuildDefaultFieldMap(AMap: TExportFields);
148
149Const
150  RightAlignedFields = IntFieldTypes+FloatFieldTypes;
151
152  // Mapping to TFieldType
153  FieldWidths : Array[TFieldType] of integer =
154    (
155    {ftUnknown} -1,
156    {ftString} 0,
157    {ftSmallint} 3,
158    {ftInteger} 10,
159    {ftWord} 5,
160    {ftBoolean} 1,
161    {ftFloat} 20,
162    {ftCurrency} 20,
163    {ftBCD} 20,
164    {ftDate} 10,
165    {ftTime} 8,
166    {ftDateTime} 20,
167    {ftBytes} 0,
168    {ftVarBytes} 0,
169    {ftAutoInc} 10,
170    {ftBlob} 0,
171    {ftMemo} 0,
172    {ftGraphic} 0,
173    {ftFmtMemo} 0,
174    {ftParadoxOle} 0,
175    {ftDBaseOle} 0,
176    {ftTypedBinary} 0,
177    {ftCursor} 0,
178    {ftFixedChar} 0,
179    {ftWideString} 0,
180    {ftLargeint} 0,
181    {ftADT} 0,
182    {ftArray} 0,
183    {ftReference} 0,
184    {ftDataSet} 0,
185    {ftOraBlob} 0,
186    {ftOraClob} 0,
187    {ftVariant} 0,
188    {ftInterface} 0,
189    {ftIDispatch} 0,
190    {ftGuid} 0,
191    {ftTimeStamp} 0,
192    {ftFMTBcd} 0,
193    {ftFixedWideChar} 0,
194    {ftWideMemo} 0
195    );
196
197  Function CalcLbool: integer;
198  var
199    LTrue,LFalse : Integer;
200
201  begin
202    Case charmode of
203    cmUTF8:
204      begin
205      LTrue:=Length(UTF8Decode(FormatSettings.BooleanTrue));
206      LFalse:=Length(UTF8Decode(FormatSettings.BooleanFalse));
207      end;
208     else
209       LTrue:=Length(FormatSettings.BooleanTrue);
210       LFalse:=Length(FormatSettings.BooleanFalse);
211     end;
212    Result:=Max(LTrue,LFalse);
213  end;
214
215
216Var
217  I,W,LBool : Integer;
218  F : TField;
219  FL : TFixedLengthExportFieldItem;
220
221begin
222  inherited BuildDefaultFieldMap(AMap);
223  lbool:=0;
224  For I:=0 to AMap.Count-1 do
225    begin
226    FL:=TFixedLengthExportFieldItem(AMAP[i]);
227    F:=Dataset.Fields[i];
228    W:= FieldWidths[F.DataType];
229    if F.DataType = ftBoolean then
230      begin
231      if lBool=0 then
232        LBool:=CalcLBool;
233      W:=lBool;
234      end;
235    If (W>0) then
236      FL.Width:=W
237    else if (W=0) then
238      begin
239      if (F.DataType in StringFieldTypes) then
240        FL.Width:=F.Size;
241      end;
242    If (F.DataType in RightAlignedFields) then
243      Fl.AlignField:=afRight;
244    end;
245end;
246
247function TCustomFixedLengthExporter.CreateExportFields: TExportFields;
248begin
249  Result:=TExportFields.Create(TFixedLengthExportFieldItem);
250end;
251
252function TCustomFixedLengthExporter.CreateFormatSettings: TCustomExportFormatSettings;
253begin
254  Result:=TFixedExportFormatSettings.Create(True);
255end;
256
257procedure TCustomFixedLengthExporter.DoBeforeExecute;
258begin
259  inherited DoBeforeExecute;
260  OpenTextFile;
261  FSpaces:=StringOfChar(' ',FormatSettings.ColumnSeparatorSpaceCount);
262  FSpacesUnicode:=StringOfChar(' ',FormatSettings.ColumnSeparatorSpaceCount);
263end;
264
265procedure TCustomFixedLengthExporter.DoAfterExecute;
266begin
267  CloseTextFile;
268  inherited DoAfterExecute;
269end;
270
271
272procedure TCustomFixedLengthExporter.DoDataRowStart;
273begin
274  FCurrentRow:='';
275end;
276
277procedure TCustomFixedLengthExporter.ExportField(EF: TExportFieldItem);
278
279begin
280  Case CharMode of
281    cmANSI : ExportFieldAnsi(EF);
282    cmUTF8 : ExportFieldUTF8(EF);
283    cmUTF16 : ExportFieldUTF16(EF);
284  end;
285end;
286
287
288Function TCustomFixedLengthExporter.ExportFieldAsUniCodeString(EF: TExportFieldItem; isHeader : Boolean = False) : UnicodeString;
289
290Var
291  S,SS : UnicodeString;
292  FL : TFixedLengthExportFieldItem;
293  L,W : Integer;
294
295begin
296  if isHeader then
297    S:=UTF8Decode(EF.ExportedName)
298  else
299    S:=UTF8Decode(FormatField(EF.Field));
300  If EF is TFixedLengthExportFieldItem then
301    begin
302    FL:=TFixedLengthExportFieldItem(EF);
303    W:=FL.Width;
304    end
305  else
306    W:=Length(S);
307  L:=Length(S);
308  If L>W then
309    begin
310    If (FL.AlignField=afLeft) then
311      S:=Copy(S,1,W)
312    else
313      Delete(S,1,L-W);
314    end
315  else if (L<W) then
316    begin
317    SS:=StringOfChar(' ',W-L);
318    If FL.AlignField=afRight then
319      S:=SS+S
320    else
321      S:=S+SS;
322    end;
323  Result:=S;
324end;
325
326procedure TCustomFixedLengthExporter.ExportFieldUTF16(EF: TExportFieldItem; isHeader : Boolean = False);
327
328begin
329  if (FormatSettings.ColumnSeparatorSpaceCount>0) and (Length(FCurrentRowUnicode)>0) then
330    FCurrentRowUnicode:=FCurrentRowUnicode+FSpacesUnicode;
331
332  FCurrentRowUnicode:=FCurrentRowUnicode+ExportFieldAsUnicodeString(EF,isHeader);
333end;
334
335
336procedure TCustomFixedLengthExporter.ExportFieldUTF8(EF: TExportFieldItem; isHeader : Boolean = False);
337
338
339begin
340  if (FormatSettings.ColumnSeparatorSpaceCount>0) and (Length(FCurrentRow)>0) then
341    FCurrentRow:=FCurrentRow+FSpaces;
342  FCurrentRow:=FCurrentRow+UTF8Encode(ExportFieldAsUnicodeString(EF,isHeader));
343end;
344
345procedure TCustomFixedLengthExporter.ExportFieldAnsi(EF: TExportFieldItem; isHeader : Boolean = False);
346
347Var
348  S,SS : String;
349  W,L : Integer;
350  FL : TFixedLengthExportFieldItem;
351
352begin
353  if isHeader then
354    S:=EF.ExportedName
355  else
356    S:=FormatField(EF.Field);
357  If EF is TFixedLengthExportFieldItem then
358    begin
359    FL:=TFixedLengthExportFieldItem(EF);
360    W:=FL.Width;
361    end
362  else
363    W:=Length(S);
364  L:=Length(S);
365  If L>W then
366    begin
367    If (FL.AlignField=afLeft) then
368      S:=Copy(S,1,W)
369    else
370      Delete(S,1,L-W);
371    end
372  else if (L<W) then
373    begin
374    SS:=StringOfChar(' ',W-L);
375    If FL.AlignField=afRight then
376      S:=SS+S
377    else
378      S:=S+SS;
379    end;
380  if (FormatSettings.ColumnSeparatorSpaceCount>0) and (Length(FCurrentRow)>0) then
381    FCurrentRow:=FCurrentRow+FSpaces;
382  FCurrentRow:=FCurrentRow+S;
383end;
384
385procedure TCustomFixedLengthExporter.DoDataRowEnd;
386begin
387  if (CharMode<>cmUTF16) then
388    Writeln(TextFile,FCurrentRow)
389  else
390    Writeln(TextFile,FCurrentRowUnicode);
391  FCurrentRow:='';
392  FCurrentRowUnicode:='';
393end;
394
395procedure TCustomFixedLengthExporter.DoDataHeader;
396
397Var
398  I : Integer;
399  EF: TExportFieldItem;
400
401begin
402  FCurrentRow:='';
403  if FormatSettings.HeaderRow then
404    begin
405    For I:=0 to ExportFields.Count-1 do
406      begin
407      EF:=ExportFields[I];
408      If EF.Enabled then
409        Case CharMode of
410          cmANSI : ExportFieldAnsi(EF,True);
411          cmUTF8 : ExportFieldUTF8(EF,True);
412          cmUTF16 : ExportFieldUTF16(EF,True);
413        end;
414      end;
415    DoDataRowEnd;
416    end;
417  inherited DoDataHeader;
418end;
419
420Procedure RegisterFixedExportFormat;
421
422begin
423  ExportFormats.RegisterExportFormat(SFixedLengthExport,SFixedLengthDescription,SFixedLengthExtensions,TFixedLengthExporter);
424end;
425
426Procedure UnRegisterFixedExportFormat;
427
428begin
429  Exportformats.UnregisterExportFormat(SFixedLengthExport);
430end;
431
432end.
433
434