Subversion Repositories delphiutils

Compare Revisions

Regard whitespace Rev 88 → Rev 89

/trunk/Units/AsciiTable.pas
0,0 → 1,307
unit AsciiTable;
 
(*
* ASCII Table and CSV Generator Delphi Unit
* Revision 2022-07-09
*
* (C) 2022 Daniel Marschall, HickelSOFT, ViaThinkSoft
* Licensed under the terms of Apache 2.0
*)
 
{
 
Example usage:
 
uses
AsciiTable, ContNrs;
 
procedure TForm1.Button1Click(Sender: TObject);
var
VirtTable: TVtsAsciiTable;
objLine: TVtsAsciiTableLine;
begin
VirtTable := TVtsAsciiTable.Create(true);
VirtTable.Clear;
 
// Create Test data
objLine := TVtsAsciiTableLine.Create;
objLine.SetVal(0, 'Fruit', taCenter);
objLine.SetVal(1, 'Amount', taCenter);
VirtTable.Add(objLine);
 
VirtTable.AddSeparator;
 
objLine := TVtsAsciiTableLine.Create;
objLine.SetVal(0, 'Apple', taLeftJustify);
objLine.SetVal(1, '123', taRightJustify);
VirtTable.Add(objLine);
 
objLine := TVtsAsciiTableLine.Create;
objLine.SetVal(0, 'Kiwi', taLeftJustify);
objLine.SetVal(1, '1', taRightJustify);
VirtTable.Add(objLine);
 
objLine := TVtsAsciiTableLine.Create;
objLine.SetVal(0, 'Asparagus (green)', taLeftJustify);
objLine.SetVal(1, '9999', taRightJustify);
VirtTable.Add(objLine);
 
objLine := TVtsAsciiTableLine.Create;
objLine.SetVal(0, 'Asparagus (white)', taLeftJustify);
objLine.SetVal(1, '999', taRightJustify);
VirtTable.Add(objLine);
 
// Create ASCII Table
Memo1.Clear;
VirtTable.GetASCIITable(Memo1.Lines);
 
// Create CSV
Memo2.Clear;
VirtTable.GetCSV(Memo2.Lines);
Memo2.Lines.SaveToFile('Order.csv');
 
VirtTable.Free;
end;
 
}
 
interface
 
uses
ContNrs, Classes, SysUtils;
 
const
VTS_ASCII_TABLE_COLS = 10;
 
type
TVtsAsciiTableLine = class(TObject)
public
Cont: array[0..VTS_ASCII_TABLE_COLS-1] of string;
Align: array[0..VTS_ASCII_TABLE_COLS-1] of TAlignment;
PadChar: array[0..VTS_ASCII_TABLE_COLS-1] of char;
procedure Clear;
procedure SetVal(index: integer; ACont: string; AAlign: TAlignment=taLeftJustify; APadChar: char=' ');
end;
 
TVtsAsciiTableAnalysis = record
MaxLen: array[0..VTS_ASCII_TABLE_COLS-1] of integer;
Used: array[0..VTS_ASCII_TABLE_COLS-1] of boolean;
Width: integer;
end;
 
TVtsAsciiTable = class(TObjectList{<TVtsAsciiTableLine>})
private
function GetItem(Index: Integer): TVtsAsciiTableLine;
procedure SetItem(Index: Integer; const Value: TVtsAsciiTableLine);
public
function GetAnalysis: TVtsAsciiTableAnalysis;
procedure GetASCIITable(sl: TStrings; spaceBetween: integer=3);
procedure GetCSV(sl: TStrings);
 
procedure AddSeparator;
 
// Just a little bit type-safe... The rest stays TObject for now
function Add(AObject: TVtsAsciiTableLine): Integer; reintroduce;
property Items[Index: Integer]: TVtsAsciiTableLine read GetItem write SetItem;
procedure Insert(Index: Integer; AObject: TVtsAsciiTableLine); reintroduce;
end;
 
implementation
 
{ TVtsAsciiTable }
 
function TVtsAsciiTable.Add(AObject: TVtsAsciiTableLine): Integer;
begin
result := Inherited Add(AObject);
end;
 
procedure TVtsAsciiTable.AddSeparator;
begin
Inherited Add(nil);
end;
 
function TVtsAsciiTable.GetAnalysis: TVtsAsciiTableAnalysis;
var
j: Integer;
i: Integer;
objLine: TVtsAsciiTableLine;
len: Integer;
begin
for j := 0 to VTS_ASCII_TABLE_COLS-1 do
begin
result.MaxLen[j] := 0;
result.Used[j] := false;
end;
for i := 0 to Self.Count-1 do
begin
objLine := Self.items[i] as TVtsAsciiTableLine;
if objLine <> nil then
begin
for j := 0 to VTS_ASCII_TABLE_COLS-1 do
begin
len := Length(objLine.Cont[j]);
if len > result.MaxLen[j] then
result.MaxLen[j] := len;
if len > 0 then
result.Used[j] := true;
end;
end;
end;
end;
 
procedure TVtsAsciiTable.GetASCIITable(sl: TStrings; spaceBetween: integer=3);
var
analysis: TVtsAsciiTableAnalysis;
objLine: TVtsAsciiTableLine;
i: Integer;
sLine: string;
j: Integer;
itmp: Integer;
padchar: Char;
firstcol: boolean;
width: Integer;
begin
analysis := GetAnalysis;
//sl.Clear;
for i := 0 to Self.Count-1 do
begin
objLine := Self.items[i] as TVtsAsciiTableLine;
sLine := '';
if objLine <> nil then
begin
firstcol := true;
for j := 0 to VTS_ASCII_TABLE_COLS-1 do
begin
if not analysis.Used[j] then continue;
 
padchar := objLine.PadChar[j];
if padchar = #0 then padchar := ' ';
 
if firstcol then
firstcol := false
else
sLine := sLine + StringOfChar(' ', spaceBetween);
 
if objLine.Align[j] = taRightJustify then
begin
sLine := sLine + StringOfChar(padchar, analysis.MaxLen[j]-Length(objLine.Cont[j]));
sLine := sLine + objLine.Cont[j];
end
else if objLine.Align[j] = taLeftJustify then
begin
sLine := sLine + objLine.Cont[j];
sLine := sLine + StringOfChar(padchar, analysis.MaxLen[j]-Length(objLine.Cont[j]));
end
else if objLine.Align[j] = taCenter then
begin
if Odd(analysis.MaxLen[j]-Length(objLine.Cont[j])) then itmp := 1 else itmp := 0;
sLine := sLine + StringOfChar(padchar, (analysis.MaxLen[j]-Length(objLine.Cont[j])) div 2);
sLine := sLine + objLine.Cont[j];
sLine := sLine + StringOfChar(padchar, (analysis.MaxLen[j]-Length(objLine.Cont[j])) div 2 + itmp);
end
else
Assert(false);
end;
end
else
begin
firstcol := true;
width := 0;
for j := 0 to VTS_ASCII_TABLE_COLS-1 do
begin
if not analysis.Used[j] then continue;
if firstcol then
firstcol := false
else
width := width + spaceBetween;
width := width + analysis.MaxLen[j];
end;
 
sLine := sLine + StringOfChar('-', Width);
end;
sl.Add(sLine);
end;
end;
 
function CsvQuoteStr(s: string): string;
begin
s := StringReplace(s, #13#10, ' ', [rfReplaceAll]);
s := StringReplace(s, #13, ' ', [rfReplaceAll]);
s := StringReplace(s, #10, ' ', [rfReplaceAll]);
if s = '' then
result := ''
else if (AnsiPos('"', s)>0) or (AnsiPos('''', s)>0) or (AnsiPos(';', s)>0) or
(AnsiPos(#9, s)>0) or (AnsiPos(' ', s)>0) then
result := '"' + StringReplace(s, '"', '""', [rfReplaceAll]) + '"'
else
result := s;
end;
 
procedure TVtsAsciiTable.GetCSV(sl: TStrings);
var
analysis: TVtsAsciiTableAnalysis;
objLine: TVtsAsciiTableLine;
i: Integer;
sLine: string;
j: Integer;
firstcol: boolean;
begin
analysis := GetAnalysis;
//sl.Clear;
for i := 0 to Self.Count-1 do
begin
objLine := Self.items[i] as TVtsAsciiTableLine;
if objLine = nil then continue;
sLine := '';
firstcol := true;
for j := 0 to VTS_ASCII_TABLE_COLS-1 do
begin
if not analysis.Used[j] then continue;
if firstcol then
firstcol := false
else
sLine := sLine + ';';
sLine := sLine + CsvQuoteStr(objLine.Cont[j]);
end;
sl.Add(sLine);
end;
end;
 
function TVtsAsciiTable.GetItem(Index: Integer): TVtsAsciiTableLine;
begin
result := (Inherited Items[Index]) as TVtsAsciiTableLine;
end;
 
procedure TVtsAsciiTable.Insert(Index: Integer; AObject: TVtsAsciiTableLine);
begin
Inherited Insert(Index, AObject);
end;
 
procedure TVtsAsciiTable.SetItem(Index: Integer; const Value: TVtsAsciiTableLine);
begin
Inherited Items[Index] := Value;
end;
 
{ TVtsAsciiTableLine }
 
procedure TVtsAsciiTableLine.Clear;
var
i: Integer;
begin
for i := 0 to VTS_ASCII_TABLE_COLS-1 do
begin
PadChar[i] := #0;
Align[i] := taLeftJustify;
Cont[i] := '';
end;
end;
 
procedure TVtsAsciiTableLine.SetVal(index: integer; ACont: string;
AAlign: TAlignment=taLeftJustify; APadChar: char=' ');
begin
Self.Cont[index] := ACont;
Self.Align[index] := AAlign;
Self.PadChar[index] := APadChar;
end;
 
end.