Context Navigation

Table.pas

Visit:

Last change on this file was 227, checked in by chronos, 17 months ago
Added: Test form. Added: Interface translation. Added: Common package.
File size: 7.2 KB

Line
1	unit Table;
2
3	interface
4
5	uses
6	Classes, SysUtils, Generics.Collections, ComCtrls;
7
8	type
9	TTableFormat = (tfExcel, tfPlain, tfCsv, tfHtml, tfListView, tfMediaWiki, tfXml);
10
11	{ TRow }
12
13	TRow = class
14	Cells: TStringList;
15	procedure AddCell(Text: string);
16	constructor Create;
17	destructor Destroy; override;
18	end;
19
20	{ TTable }
21
22	TTable = class
23	private
24	function QuoteCsvString(Text: string): string;
25	function ReplaceXmlEntities(Text: string): string;
26	public
27	Title: string;
28	Columns: TStringList;
29	Rows: TObjectList<TRow>;
30	FirstRowIsHeader: Boolean;
31	procedure Clear;
32	function AddRow: TRow;
33	function GetOutputTabs: string;
34	function GetOutputPlain: string;
35	function GetOutputCsv: string;
36	function GetOutputXml: string;
37	function GetOutputHtml: string;
38	function GetOutputMediaWiki: string;
39	procedure GetOutputListView(ListView: TListView);
40	function GetOutput(OutputFormat: TTableFormat): string;
41	constructor Create;
42	destructor Destroy; override;
43	end;
44
45	const
46	TableFormatText: array[TTableFormat] of string = ('Excel paste', 'Plain text', 'CSV',
47	'HTML', 'ListView', 'MediaWiki', 'XML');
48	TableFormatExt: array[TTableFormat] of string = ('.txt', '.txt', '.csv',
49	'.htm', '', '.txt', '.xml');
50
51
52	implementation
53
54	uses
55	Common;
56
57	{ TTable }
58
59	function TTable.QuoteCsvString(Text: string): string;
60	begin
61	if Text <> '' then Result := '"' + Text + '"'
62	else Result := Text;
63	end;
64
65	function TTable.ReplaceXmlEntities(Text: string): string;
66	begin
67	Result := StringReplace(Text, '<', '<', [rfReplaceAll]);
68	Result := StringReplace(Result, '>', '>', [rfReplaceAll]);
69	Result := StringReplace(Result, '&', '&', [rfReplaceAll]);
70	Result := StringReplace(Result, '''', ''', [rfReplaceAll]);
71	Result := StringReplace(Result, '"', '"', [rfReplaceAll]);
72	end;
73
74	procedure TTable.Clear;
75	begin
76	Rows.Clear;
77	end;
78
79	function TTable.AddRow: TRow;
80	begin
81	Result := TRow.Create;
82	Rows.Add(Result);
83	end;
84
85	function TTable.GetOutputTabs: string;
86	var
87	I: Integer;
88	begin
89	Result := '';
90	for I := 0 to Rows.Count - 1 do
91	Result := Result + Implode(#9, Rows[I].Cells) + LineEnding;
92	end;
93
94	function TTable.GetOutputPlain: string;
95	var
96	I: Integer;
97	begin
98	Result := '';
99	for I := 0 to Rows.Count - 1 do begin
100	Result := Result + Implode(LineEnding, Rows[I].Cells) + LineEnding;
101	Result := Result + LineEnding;
102	Result := Result + '===========================' + LineEnding;
103	Result := Result + LineEnding;
104	end;
105	end;
106
107	function TTable.GetOutputCsv: string;
108	var
109	I: Integer;
110	J: Integer;
111	begin
112	Result := '';
113
114	// Show columns
115	for J := 0 to Columns.Count - 1 do begin
116	if J > 0 then Result := Result + ',';
117	if Columns[J] <> '' then
118	Result := Result + QuoteCsvString(Columns[J]);
119	end;
120	Result := Result + LineEnding;
121
122	// Show data rows
123	for I := 0 to Rows.Count - 1 do
124	with Rows[I] do begin
125	for J := 0 to Cells.Count - 1 do begin
126	if J > 0 then Result := Result + ',';
127	if Cells[J] <> '' then
128	Result := Result + QuoteCsvString(Cells[J]);
129	end;
130	Result := Result + LineEnding;
131	end;
132	end;
133
134	function TTable.GetOutputXml: string;
135	var
136	I: Integer;
137	J: Integer;
138	begin
139	Result := '<?xml version="1.0" encoding="UTF-8"?>' + LineEnding +
140	'<vcard>' + LineEnding +
141	' <title>' + Title + '</title>' + LineEnding +
142	' <contacts>' + LineEnding;
143	for I := 0 to Rows.Count - 1 do begin
144	Result := Result + ' <contact>' + LineEnding;
145	for J := 0 to Rows[I].Cells.Count - 1 do
146	if Rows[I].Cells[J] <> '' then
147	Result := Result + ' <property name="' + Columns[J] + '">' + ReplaceXmlEntities(Rows[I].Cells[J]) + '</property>' + LineEnding;
148	Result := Result + ' </contact>' + LineEnding;
149	end;
150	Result := Result + ' </contacts>' + LineEnding +
151	'</vcard>';
152	end;
153
154	function TTable.GetOutputHtml: string;
155	var
156	I: Integer;
157	J: Integer;
158	begin
159	Result := '<html>' + LineEnding +
160	' <head>' + LineEnding +
161	' <title>' + Title + '</title>' + LineEnding +
162	' </head>' + LineEnding +
163	' <body>' + LineEnding +
164	' <table border="1">' + LineEnding;
165	// Show header
166	Result := Result + ' <tr>' + LineEnding;
167	for J := 0 to Columns.Count - 1 do
168	Result := Result + ' <th>' + StringReplace(Columns[J], LineEnding, '<br/>', [rfReplaceAll]) + '</th>' + LineEnding;
169	Result := Result + ' </tr>' + LineEnding;
170
171	// Show data rows
172	for I := 0 to Rows.Count - 1 do begin
173	Result := Result + ' <tr>' + LineEnding;
174	for J := 0 to Rows[I].Cells.Count - 1 do
175	Result := Result + ' <td>' + StringReplace(Rows[I].Cells[J], LineEnding, '<br/>', [rfReplaceAll]) + '</td>' + LineEnding;
176	Result := Result + ' </tr>' + LineEnding;
177	end;
178	Result := Result + ' </table>' + LineEnding +
179	' </body>' + LineEnding +
180	'</html>';
181	end;
182
183	function TTable.GetOutputMediaWiki: string;
184	var
185	I: Integer;
186	J: Integer;
187	begin
188	Result := '{\| class="wikitable sortable"' + LineEnding;
189
190	// Show header
191	for J := 0 to Columns.Count - 1 do begin
192	if J = 0 then Result := Result + '! ' + Columns[J]
193	else Result := Result + ' !! ' + Columns[J];
194	end;
195	Result := Result + LineEnding + '\|-' + LineEnding;
196
197	// Show data rows
198	for I := 0 to Rows.Count - 1 do begin
199	for J := 0 to Rows[I].Cells.Count - 1 do begin
200	if J = 0 then Result := Result + '\| ' + Rows[I].Cells[J]
201	else Result := Result + ' \|\| ' + Rows[I].Cells[J];
202	end;
203	if I < Rows.Count - 1 then
204	Result := Result + LineEnding + '\|-' + LineEnding;
205	end;
206	Result := Result + LineEnding + '\|}';
207	end;
208
209	procedure TTable.GetOutputListView(ListView: TListView);
210	var
211	I: Integer;
212	J: Integer;
213	ListColumn: TListColumn;
214	ListItem: TListItem;
215	NewWidth: Integer;
216	const
217	MinWidth = 120;
218	begin
219	ListView.Columns.BeginUpdate;
220	try
221	ListView.Columns.Clear;
222	for I := 0 to Columns.Count - 1 do begin
223	ListColumn := ListView.Columns.Add;
224	ListColumn.Caption := Columns[I];
225	NewWidth := ListView.Width div Columns.Count;
226	if NewWidth < MinWidth then NewWidth := MinWidth;
227	ListColumn.Width := NewWidth;
228	end;
229	finally
230	ListView.Columns.EndUpdate;
231	end;
232
233	ListView.Items.BeginUpdate;
234	try
235	ListView.Items.Clear;
236	for I := 0 to Rows.Count - 1 do begin
237	ListItem := ListView.Items.Add;
238	for J := 0 to Rows[I].Cells.Count - 1 do begin
239	if J = 0 then ListItem.Caption := Rows[I].Cells[J]
240	else ListItem.SubItems.Add(Rows[I].Cells[J]);
241	end;
242	end;
243	finally
244	ListView.Items.EndUpdate;
245	end;
246	end;
247
248	function TTable.GetOutput(OutputFormat: TTableFormat): string;
249	begin
250	case OutputFormat of
251	tfExcel: Result := GetOutputTabs;
252	tfPlain: Result := GetOutputPlain;
253	tfCsv: Result := GetOutputCsv;
254	tfHtml: Result := GetOutputHtml;
255	tfMediaWiki: Result := GetOutputMediaWiki;
256	tfXml: Result := GetOutputXml;
257	else Result := '';
258	end;
259	end;
260
261	constructor TTable.Create;
262	begin
263	Columns := TStringList.Create;
264	Rows := TObjectList<TRow>.Create;
265	end;
266
267	destructor TTable.Destroy;
268	begin
269	FreeAndNil(Rows);
270	FreeAndNil(Columns);
271	inherited;
272	end;
273
274	procedure TRow.AddCell(Text: string);
275	begin
276	Cells.Add(Text);
277	end;
278
279	constructor TRow.Create;
280	begin
281	Cells := TStringList.Create;
282	end;
283
284	destructor TRow.Destroy;
285	begin
286	FreeAndNil(Cells);
287	inherited;
288	end;
289
290	end.
291

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: branches/xpascal/Packages/Common/Table.pas

Download in other formats: