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