Subversion Repositories delphiutils

Rev

Rev 92 | Rev 94 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
89 daniel-mar 1
unit AsciiTable;
2
 
3
(*
4
 * ASCII Table and CSV Generator Delphi Unit
93 daniel-mar 5
 * Revision 2022-07-15
89 daniel-mar 6
 *
7
 * (C) 2022 Daniel Marschall, HickelSOFT, ViaThinkSoft
8
 * Licensed under the terms of Apache 2.0
9
 *)
10
 
11
{
12
 
13
Example usage:
14
 
15
uses
16
  AsciiTable, ContNrs;
17
 
18
procedure TForm1.Button1Click(Sender: TObject);
19
var
20
  VirtTable: TVtsAsciiTable;
21
  objLine: TVtsAsciiTableLine;
22
begin
23
  VirtTable := TVtsAsciiTable.Create(true);
24
  VirtTable.Clear;
25
 
26
  // Create Test data
27
  objLine := TVtsAsciiTableLine.Create;
28
  objLine.SetVal(0, 'Fruit', taCenter);
29
  objLine.SetVal(1, 'Amount', taCenter);
30
  VirtTable.Add(objLine);
31
 
32
  VirtTable.AddSeparator;
33
 
34
  objLine := TVtsAsciiTableLine.Create;
35
  objLine.SetVal(0, 'Apple', taLeftJustify);
36
  objLine.SetVal(1, '123', taRightJustify);
37
  VirtTable.Add(objLine);
38
 
39
  objLine := TVtsAsciiTableLine.Create;
40
  objLine.SetVal(0, 'Kiwi', taLeftJustify);
41
  objLine.SetVal(1, '1', taRightJustify);
42
  VirtTable.Add(objLine);
43
 
44
  objLine := TVtsAsciiTableLine.Create;
45
  objLine.SetVal(0, 'Asparagus (green)', taLeftJustify);
46
  objLine.SetVal(1, '9999', taRightJustify);
47
  VirtTable.Add(objLine);
48
 
49
  objLine := TVtsAsciiTableLine.Create;
50
  objLine.SetVal(0, 'Asparagus (white)', taLeftJustify);
51
  objLine.SetVal(1, '999', taRightJustify);
52
  VirtTable.Add(objLine);
53
 
91 daniel-mar 54
  VirtTable.AddSeparator;
55
  VirtTable.AddSumLine;
56
 
90 daniel-mar 57
  // Create ASCII table
89 daniel-mar 58
  Memo1.Clear;
59
  VirtTable.GetASCIITable(Memo1.Lines);
60
 
90 daniel-mar 61
  // Save ASCII table
62
  VirtTable.SaveASCIITable('Order.txt');
63
 
89 daniel-mar 64
  // Create CSV
65
  Memo2.Clear;
66
  VirtTable.GetCSV(Memo2.Lines);
67
 
90 daniel-mar 68
  // Save CSV
69
  VirtTable.SaveCSV('Order.csv');
70
 
89 daniel-mar 71
  VirtTable.Free;
72
end;
73
 
74
}
75
 
76
interface
77
 
78
uses
79
  ContNrs, Classes, SysUtils;
80
 
81
const
82
  VTS_ASCII_TABLE_COLS = 10;
83
 
84
type
85
  TVtsAsciiTableLine = class(TObject)
91 daniel-mar 86
  private
87
    IsSumLine: boolean;
88
    //IsSeparator: boolean;
89 daniel-mar 89
  public
90
    Cont: array[0..VTS_ASCII_TABLE_COLS-1] of string;
91
    Align: array[0..VTS_ASCII_TABLE_COLS-1] of TAlignment;
92
    PadChar: array[0..VTS_ASCII_TABLE_COLS-1] of char;
92 daniel-mar 93
    DoSum: array[0..VTS_ASCII_TABLE_COLS-1] of boolean;
89 daniel-mar 94
    procedure Clear;
92 daniel-mar 95
    procedure SetVal(index: integer; ACont: string; AAlign: TAlignment=taLeftJustify;
96
      APadChar: char=' '; ADoSum: boolean=false);
89 daniel-mar 97
  end;
98
 
99
  TVtsAsciiTableAnalysis = record
100
    MaxLen: array[0..VTS_ASCII_TABLE_COLS-1] of integer;
101
    Used: array[0..VTS_ASCII_TABLE_COLS-1] of boolean;
91 daniel-mar 102
    Sum: array[0..VTS_ASCII_TABLE_COLS-1] of integer;
89 daniel-mar 103
  end;
104
 
105
  TVtsAsciiTable = class(TObjectList{<TVtsAsciiTableLine>})
106
  private
107
    function GetItem(Index: Integer): TVtsAsciiTableLine;
108
    procedure SetItem(Index: Integer; const Value: TVtsAsciiTableLine);
109
  public
110
    function GetAnalysis: TVtsAsciiTableAnalysis;
93 daniel-mar 111
    procedure GetASCIITable(sl: TStrings; spaceBetween: integer=3); overload;
112
    function GetASCIITable(spaceBetween: integer=3): string; overload;
90 daniel-mar 113
    procedure SaveASCIITable(filename: string; spaceBetween: integer=3);
89 daniel-mar 114
    procedure GetCSV(sl: TStrings);
90 daniel-mar 115
    procedure SaveCSV(filename: string);
89 daniel-mar 116
 
117
    procedure AddSeparator;
91 daniel-mar 118
    procedure AddSumLine;
89 daniel-mar 119
 
120
    // Just a little bit type-safe... The rest stays TObject for now
121
    function Add(AObject: TVtsAsciiTableLine): Integer; reintroduce;
122
    property Items[Index: Integer]: TVtsAsciiTableLine read GetItem write SetItem;
123
    procedure Insert(Index: Integer; AObject: TVtsAsciiTableLine); reintroduce;
124
  end;
125
 
126
implementation
127
 
128
{ TVtsAsciiTable }
129
 
130
function TVtsAsciiTable.Add(AObject: TVtsAsciiTableLine): Integer;
131
begin
132
  result := Inherited Add(AObject);
133
end;
134
 
135
procedure TVtsAsciiTable.AddSeparator;
136
begin
137
  Inherited Add(nil);
138
end;
139
 
91 daniel-mar 140
procedure TVtsAsciiTable.AddSumLine;
141
var
142
  objLine: TVtsAsciiTableLine;
143
  j: Integer;
144
  analysis: TVtsAsciiTableAnalysis;
92 daniel-mar 145
  found: boolean;
91 daniel-mar 146
begin
147
  objLine := TVtsAsciiTableLine.Create;
148
  objLine.IsSumLine := true;
149
  analysis := GetAnalysis;
92 daniel-mar 150
  found := false;
91 daniel-mar 151
  for j := 0 to VTS_ASCII_TABLE_COLS-1 do
152
  begin
153
    if analysis.Sum[j] <> 0 then
92 daniel-mar 154
    begin
91 daniel-mar 155
      objLine.SetVal(j, IntToStr(analysis.Sum[j]), taRightJustify, ' ');
92 daniel-mar 156
      found := true;
157
    end;
91 daniel-mar 158
  end;
92 daniel-mar 159
  if found then
160
    Inherited Add(objLine)
161
  else
162
    objLine.Free;
91 daniel-mar 163
end;
164
 
89 daniel-mar 165
function TVtsAsciiTable.GetAnalysis: TVtsAsciiTableAnalysis;
166
var
167
  j: Integer;
168
  i: Integer;
169
  objLine: TVtsAsciiTableLine;
170
  len: Integer;
91 daniel-mar 171
  itmp: integer;
89 daniel-mar 172
begin
173
  for j := 0 to VTS_ASCII_TABLE_COLS-1 do
174
  begin
175
    result.MaxLen[j] := 0;
176
    result.Used[j] := false;
91 daniel-mar 177
    result.Sum[j] := 0;
89 daniel-mar 178
  end;
179
  for i := 0 to Self.Count-1 do
180
  begin
181
    objLine := Self.items[i] as TVtsAsciiTableLine;
182
    if objLine <> nil then
183
    begin
184
      for j := 0 to VTS_ASCII_TABLE_COLS-1 do
185
      begin
186
        len := Length(objLine.Cont[j]);
92 daniel-mar 187
        if TryStrToInt(objLine.Cont[j], itmp) and objLine.DoSum[j] then
91 daniel-mar 188
          result.Sum[j] := result.Sum[j] + itmp;
89 daniel-mar 189
        if len > result.MaxLen[j] then
190
          result.MaxLen[j] := len;
191
        if len > 0 then
192
          result.Used[j] := true;
193
      end;
194
    end;
195
  end;
196
end;
197
 
93 daniel-mar 198
function TVtsAsciiTable.GetASCIITable(spaceBetween: integer): string;
199
var
200
  sl: TStringList;
201
begin
202
  sl := TStringList.Create;
203
  try
204
    GetASCIITable(sl, spaceBetween);
205
    result := sl.Text;
206
  finally
207
    FreeAndNil(sl);
208
  end;
209
end;
210
 
89 daniel-mar 211
procedure TVtsAsciiTable.GetASCIITable(sl: TStrings; spaceBetween: integer=3);
212
var
213
  analysis: TVtsAsciiTableAnalysis;
214
  objLine: TVtsAsciiTableLine;
215
  i: Integer;
216
  sLine: string;
217
  j: Integer;
218
  itmp: Integer;
219
  padchar: Char;
220
  firstcol: boolean;
221
  width: Integer;
222
begin
223
  analysis := GetAnalysis;
224
  //sl.Clear;
225
  for i := 0 to Self.Count-1 do
226
  begin
227
    objLine := Self.items[i] as TVtsAsciiTableLine;
228
    sLine := '';
229
    if objLine <> nil then
230
    begin
231
      firstcol := true;
232
      for j := 0 to VTS_ASCII_TABLE_COLS-1 do
233
      begin
234
        if not analysis.Used[j] then continue;
235
 
236
        padchar := objLine.PadChar[j];
237
        if padchar = #0 then padchar := ' ';
238
 
239
        if firstcol then
240
          firstcol := false
241
        else
242
          sLine := sLine + StringOfChar(' ', spaceBetween);
243
 
244
        if objLine.Align[j] = taRightJustify then
245
        begin
246
          sLine := sLine + StringOfChar(padchar, analysis.MaxLen[j]-Length(objLine.Cont[j]));
247
          sLine := sLine + objLine.Cont[j];
248
        end
249
        else if objLine.Align[j] = taLeftJustify then
250
        begin
251
          sLine := sLine + objLine.Cont[j];
252
          sLine := sLine + StringOfChar(padchar, analysis.MaxLen[j]-Length(objLine.Cont[j]));
253
        end
254
        else if objLine.Align[j] = taCenter then
255
        begin
256
          if Odd(analysis.MaxLen[j]-Length(objLine.Cont[j])) then itmp := 1 else itmp := 0;
257
          sLine := sLine + StringOfChar(padchar, (analysis.MaxLen[j]-Length(objLine.Cont[j])) div 2);
258
          sLine := sLine + objLine.Cont[j];
259
          sLine := sLine + StringOfChar(padchar, (analysis.MaxLen[j]-Length(objLine.Cont[j])) div 2 + itmp);
260
        end
261
        else
262
          Assert(false);
263
      end;
264
    end
265
    else
266
    begin
267
      firstcol := true;
268
      width := 0;
269
      for j := 0 to VTS_ASCII_TABLE_COLS-1 do
270
      begin
271
        if not analysis.Used[j] then continue;
272
        if firstcol then
273
          firstcol := false
274
        else
275
          width := width + spaceBetween;
276
        width := width + analysis.MaxLen[j];
277
      end;
278
 
279
      sLine := sLine + StringOfChar('-', Width);
280
    end;
281
    sl.Add(sLine);
282
  end;
283
end;
284
 
285
function CsvQuoteStr(s: string): string;
286
begin
287
  s := StringReplace(s, #13#10, ' ', [rfReplaceAll]);
288
  s := StringReplace(s, #13, ' ', [rfReplaceAll]);
289
  s := StringReplace(s, #10, ' ', [rfReplaceAll]);
290
  if s = '' then
291
    result := ''
292
  else if (AnsiPos('"', s)>0) or (AnsiPos('''', s)>0) or (AnsiPos(';', s)>0) or
293
          (AnsiPos(#9, s)>0) or (AnsiPos(' ', s)>0) then
294
    result := '"' + StringReplace(s, '"', '""', [rfReplaceAll]) + '"'
295
  else
296
    result := s;
297
end;
298
 
299
procedure TVtsAsciiTable.GetCSV(sl: TStrings);
300
var
301
  analysis: TVtsAsciiTableAnalysis;
302
  objLine: TVtsAsciiTableLine;
303
  i: Integer;
304
  sLine: string;
305
  j: Integer;
306
  firstcol: boolean;
307
begin
308
  analysis := GetAnalysis;
309
  //sl.Clear;
310
  for i := 0 to Self.Count-1 do
311
  begin
312
    objLine := Self.items[i] as TVtsAsciiTableLine;
313
    if objLine = nil then continue;
91 daniel-mar 314
    if objLine.IsSumLine then continue;
89 daniel-mar 315
    sLine := '';
316
    firstcol := true;
317
    for j := 0 to VTS_ASCII_TABLE_COLS-1 do
318
    begin
319
      if not analysis.Used[j] then continue;
320
      if firstcol then
321
        firstcol := false
322
      else
323
        sLine := sLine + ';';
324
      sLine := sLine + CsvQuoteStr(objLine.Cont[j]);
325
    end;
326
    sl.Add(sLine);
327
  end;
328
end;
329
 
330
function TVtsAsciiTable.GetItem(Index: Integer): TVtsAsciiTableLine;
331
begin
332
  result := (Inherited Items[Index]) as TVtsAsciiTableLine;
333
end;
334
 
335
procedure TVtsAsciiTable.Insert(Index: Integer; AObject: TVtsAsciiTableLine);
336
begin
337
  Inherited Insert(Index, AObject);
338
end;
339
 
90 daniel-mar 340
procedure TVtsAsciiTable.SaveASCIITable(filename: string;
341
  spaceBetween: integer);
342
var
343
  sl: TStringList;
344
begin
345
  sl := TStringList.Create;
346
  try
347
    GetASCIITable(sl, spaceBetween);
348
    sl.SaveToFile(filename);
349
  finally
350
    FreeAndNil(sl);
351
  end;
352
end;
353
 
354
procedure TVtsAsciiTable.SaveCSV(filename: string);
355
var
356
  sl: TStringList;
357
begin
358
  sl := TStringList.Create;
359
  try
360
    GetCSV(sl);
361
    sl.SaveToFile(filename);
362
  finally
363
    FreeAndNil(sl);
364
  end;
365
end;
366
 
89 daniel-mar 367
procedure TVtsAsciiTable.SetItem(Index: Integer; const Value: TVtsAsciiTableLine);
368
begin
369
  Inherited Items[Index] := Value;
370
end;
371
 
372
{ TVtsAsciiTableLine }
373
 
374
procedure TVtsAsciiTableLine.Clear;
375
var
376
  i: Integer;
377
begin
378
  for i := 0 to VTS_ASCII_TABLE_COLS-1 do
379
  begin
380
    PadChar[i] := #0;
381
    Align[i] := taLeftJustify;
382
    Cont[i] := '';
383
  end;
384
end;
385
 
386
procedure TVtsAsciiTableLine.SetVal(index: integer; ACont: string;
92 daniel-mar 387
  AAlign: TAlignment=taLeftJustify; APadChar: char=' '; ADoSum: boolean=false);
89 daniel-mar 388
begin
389
  Self.Cont[index] := ACont;
390
  Self.Align[index] := AAlign;
391
  Self.PadChar[index] := APadChar;
92 daniel-mar 392
  Self.DoSum[index] := ADoSum;
89 daniel-mar 393
end;
394
 
395
end.