examples/Delphi/ExListU.pas

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

unit ExListU;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, ExtCtrls,

  StConst, StBase, StUtils, StList;

type
  TSTDlg = class(TForm)
    CreateBtn: TButton;
    ClearBtn: TButton;
    DeleteBtn: TButton;
    HeadBtn: TButton;
    LB1: TListBox;
    Edit1: TEdit;
    AppendBtn: TButton;
    InsertBtn: TButton;
    InsSortedBtn: TButton;
    PlaceBtn: TButton;
    PlaceBeforeBtn: TButton;
    SortBtn: TButton;
    Bevel1: TBevel;
    LoadBtn: TButton;
    SaveBtn: TButton;
    OD1: TOpenDialog;
    SD1: TSaveDialog;

    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);

    procedure CreateBtnClick(Sender: TObject);
    procedure ClearBtnClick(Sender: TObject);
    procedure DeleteBtnClick(Sender: TObject);
    procedure HeadBtnClick(Sender: TObject);
    procedure AppendBtnClick(Sender: TObject);
    procedure InsertBtnClick(Sender: TObject);
    procedure InsSortedBtnClick(Sender: TObject);
    procedure PlaceBtnClick(Sender: TObject);
    procedure PlaceBeforeBtnClick(Sender: TObject);
    procedure SortBtnClick(Sender: TObject);
    procedure LoadBtnClick(Sender: TObject);
    procedure SaveBtnClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure SetBusy(B : Boolean);
    procedure FillListBox;
    procedure UpdateButtons(LOK : Boolean);
    procedure CreateList;
  end;

var
  STDlg: TSTDlg;

implementation

{$R *.DFM}

const
  MaxElems = 5000;

type
  S10 = string[10];

var
  MyList : TStList;


function MyCompare(Data1, Data2 : Pointer) : Integer; far;
  {-global function used to sort string items in TStList based classes}
begin
  Result := CompareText(S10(Data1^),S10(Data2^));
end;

function MatchStrings(Container : TStContainer;
                      Node : TStNode;
                      OtherData : Pointer) : Boolean; far;
 {-user defined function to search for strings in a
   TStList based class. Used by the TStList.Iterate method}
begin
  Result := S10(Node.Data^) <> S10(OtherData^);
end;

procedure MyDelNodeData(Data : pointer); far;
 {-procedure to delete data pointer in each node
   during call to TStList.Destroy}
begin
  FreeMem(Data,SizeOf(S10));
end;


function MyLoadData(Reader : TReader) : Pointer; far;
begin
  GetMem(Result,SizeOf(S10));
  S10(Result^) := Reader.ReadString;
end;


procedure MyStoreData(Writer : TWriter; Data : Pointer); far;
begin
  Writer.WriteString(S10(Data^));
end;

procedure TSTDlg.FormCreate(Sender: TObject);
begin
 RegisterClasses([TStList,TStListNode]);
 UpdateButtons(False);
end;


procedure TSTDlg.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  MyList.Free;
end;

procedure TSTDlg.SetBusy(B : Boolean);
begin
  if B then
    Screen.Cursor := crHourGlass
  else
    Screen.Cursor := crDefault;
end;

procedure TSTDlg.UpdateButtons(LOK : Boolean);
begin
  ClearBtn.Enabled       := LOK;
  DeleteBtn.Enabled      := LOK;
  HeadBtn.Enabled        := LOK;
  AppendBtn.Enabled      := LOK;
  InsertBtn.Enabled      := LOK;
  InsSortedBtn.Enabled   := LOK;
  PlaceBtn.Enabled       := LOK;
  PlaceBeforeBtn.Enabled := LOK;
  SortBtn.Enabled        := LOK;
  SaveBtn.Enabled        := LOK;
end;

procedure TSTDlg.CreateList;
begin
  UpdateButtons(False);
  MyList := TStList.Create(TStListNode);

  MyList.Compare := MyCompare;
  MyList.DisposeData := MyDelNodeData;
  MyList.LoadData := MyLoadData;
  MyList.StoreData := MyStoreData;
end;


procedure TSTDlg.FillListBox;
var
  PN : TStListNode;

begin
  PN := MyList.Head;

  LB1.Clear;
  LB1.Perform(WM_SETREDRAW,0,0);
  SetBusy(True);

  while (PN <> nil) do
  begin
    LB1.Items.Add(S10(PN.Data^));
    PN := MyList.Next(PN);
  end;

  LB1.Perform(WM_SETREDRAW,1,0);
  LB1.Update;
  SetBusy(False);
end;


procedure TSTDlg.CreateBtnClick(Sender: TObject);
var
  J,
  step : integer;
  S    : ^S10;
begin
  if Assigned(MyList) then
    MyList.Free;

  CreateList;
  Randomize;
  for step := 1 to MaxElems do
  begin
    GetMem(S,SizeOf(S10));
    S^[0] := Chr(10);
    for J := 1 to 10 do
      S^[J] := Chr(random(26) + Ord('A'));
    MyList.Append(S);
  end;
  FillListBox;
  UpdateButtons(True);
end;


procedure TSTDlg.ClearBtnClick(Sender: TObject);
begin
  MyList.Clear;
  {confirm list was cleared}
  FillListBox;
end;

procedure TSTDlg.DeleteBtnClick(Sender: TObject);
var
  WhichOne : integer;
  PN : TStListNode;
  S : S10;
begin
  WhichOne := LB1.ItemIndex;
  if (WhichOne < 0) then
  begin
    ShowMessage('No item selected');
    Exit;
  end;

  S := LB1.Items[WhichOne];
  PN := MyList.Iterate(MatchStrings,True,@S);

  if (PN <> nil) then
  begin
    MyList.Delete(PN);
    FillListBox;
  end;
end;

procedure TSTDlg.HeadBtnClick(Sender: TObject);
var
  WhichOne : integer;
  S        : S10;
  PN       : TStListNode;
begin
  WhichOne := LB1.ItemIndex;
  if (WhichOne < 0) then
  begin
    ShowMessage('No item selected');
    Exit;
  end;

  S := LB1.Items[WhichOne];
  PN := MyList.Iterate(MatchStrings,True,@S);
  if (PN <> nil) then
  begin
    MyList.MoveToHead(PN);
    FillListBox;
  end;
end;

procedure TSTDlg.AppendBtnClick(Sender: TObject);
var
  S   : ^S10;
begin
  if (Edit1.Text = '') then
  begin
    ShowMessage('Empty string not allowed');
    Exit;
  end;
  GetMem(S,SizeOf(S10));
  S^ := Edit1.Text;
  MyList.Append(S);
  FillListBox;
end;

procedure TSTDlg.InsertBtnClick(Sender: TObject);
var
  S : ^S10;
begin
  if (Edit1.Text = '') then
  begin
    ShowMessage('Empty string not allowed');
    Exit;
  end;
  GetMem(S,SizeOf(S10));
  S^ := Edit1.Text;
  MyList.Insert(S);
  FillListBox;
end;

procedure TSTDlg.InsSortedBtnClick(Sender: TObject);
var
  S : ^S10;
begin
  if (Edit1.Text = '') then
  begin
    ShowMessage('Empty string not allowed');
    Exit;
  end;
  GetMem(S,SizeOf(S10));
  S^ := Edit1.Text;
  MyList.InsertSorted(S);
  FillListBox;
end;

procedure TSTDlg.PlaceBtnClick(Sender: TObject);
var
  WhichOne : integer;
  S        : ^S10;
  PS       : S10;
  PN       : TStListNode;
begin
  WhichOne := LB1.ItemIndex;
  if (WhichOne < 0) then
  begin
    ShowMessage('No item selected');
    Exit;
  end;
  if (Edit1.Text = '') then
  begin
    ShowMessage('Empty string not allowed');
    Exit;
  end;
  GetMem(S,SizeOf(S10));
  S^ := Edit1.Text;
  PS := LB1.Items[WhichOne];
  PN := MyList.Iterate(MatchStrings,True,@PS);
  if (PN <> nil) then
  begin
    MyList.Place(S,PN);
    FillListBox;
  end;
end;

procedure TSTDlg.PlaceBeforeBtnClick(Sender: TObject);
var
  WhichOne : integer;
  S        : ^S10;
  PS       : S10;
  PN       : TStListNode;

begin
  WhichOne := LB1.ItemIndex;
  if (WhichOne < 0) then
  begin
    ShowMessage('No item selected');
    Exit;
  end;
  if (Edit1.Text = '') then
  begin
    ShowMessage('Empty string not allowed');
    Exit;
  end;
  GetMem(S,SizeOf(S10));
  S^ := Edit1.Text;
  PS := LB1.Items[WhichOne];
  PN := MyList.Iterate(MatchStrings,True,@PS);
  if (PN <> nil) then
  begin
    MyList.PlaceBefore(S,PN);
    FillListBox;
  end;
end;

procedure TSTDlg.SortBtnClick(Sender: TObject);
begin
  MyList.Sort;
  FillListBox;
end;

procedure TSTDlg.LoadBtnClick(Sender: TObject);
begin
  if (OD1.Execute) then
  begin
    if (NOT Assigned(MyList)) then
      CreateList;
    MyList.Clear;
    MyList.LoadFromFile(OD1.FileName);

    FillListBox;
    UpdateButtons(True);
  end;
end;

procedure TSTDlg.SaveBtnClick(Sender: TObject);
begin
  if (SD1.Execute) then
    MyList.StoreToFile(SD1.FileName);
end;


end.
1	torben	2671	(* *** BEGIN LICENSE BLOCK ***
2			* Version: MPL 1.1
3			*
4			* The contents of this file are subject to the Mozilla Public License Version
5			* 1.1 (the "License"); you may not use this file except in compliance with
6			* the License. You may obtain a copy of the License at
7			* http://www.mozilla.org/MPL/
8			*
9			* Software distributed under the License is distributed on an "AS IS" basis,
10			* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
11			* for the specific language governing rights and limitations under the
12			* License.
13			*
14			* The Original Code is TurboPower SysTools
15			*
16			* The Initial Developer of the Original Code is
17			* TurboPower Software
18			*
19			* Portions created by the Initial Developer are Copyright (C) 1996-2002
20			* the Initial Developer. All Rights Reserved.
21			*
22			* Contributor(s):
23			*
24			* *** END LICENSE BLOCK *** *)
25
26			unit ExListU;
27
28			interface
29
30			uses
31			Windows, Messages, SysUtils, Classes, Graphics, Controls,
32			Forms, Dialogs, StdCtrls, Buttons, ExtCtrls,
33
34			StConst, StBase, StUtils, StList;
35
36			type
37			TSTDlg = class(TForm)
38			CreateBtn: TButton;
39			ClearBtn: TButton;
40			DeleteBtn: TButton;
41			HeadBtn: TButton;
42			LB1: TListBox;
43			Edit1: TEdit;
44			AppendBtn: TButton;
45			InsertBtn: TButton;
46			InsSortedBtn: TButton;
47			PlaceBtn: TButton;
48			PlaceBeforeBtn: TButton;
49			SortBtn: TButton;
50			Bevel1: TBevel;
51			LoadBtn: TButton;
52			SaveBtn: TButton;
53			OD1: TOpenDialog;
54			SD1: TSaveDialog;
55
56			procedure FormCreate(Sender: TObject);
57			procedure FormClose(Sender: TObject; var Action: TCloseAction);
58
59			procedure CreateBtnClick(Sender: TObject);
60			procedure ClearBtnClick(Sender: TObject);
61			procedure DeleteBtnClick(Sender: TObject);
62			procedure HeadBtnClick(Sender: TObject);
63			procedure AppendBtnClick(Sender: TObject);
64			procedure InsertBtnClick(Sender: TObject);
65			procedure InsSortedBtnClick(Sender: TObject);
66			procedure PlaceBtnClick(Sender: TObject);
67			procedure PlaceBeforeBtnClick(Sender: TObject);
68			procedure SortBtnClick(Sender: TObject);
69			procedure LoadBtnClick(Sender: TObject);
70			procedure SaveBtnClick(Sender: TObject);
71			private
72			{ Private declarations }
73			public
74			{ Public declarations }
75			procedure SetBusy(B : Boolean);
76			procedure FillListBox;
77			procedure UpdateButtons(LOK : Boolean);
78			procedure CreateList;
79			end;
80
81			var
82			STDlg: TSTDlg;
83
84			implementation
85
86			{$R *.DFM}
87
88			const
89			MaxElems = 5000;
90
91			type
92			S10 = string[10];
93
94			var
95			MyList : TStList;
96
97
98			function MyCompare(Data1, Data2 : Pointer) : Integer; far;
99			{-global function used to sort string items in TStList based classes}
100			begin
101			Result := CompareText(S10(Data1^),S10(Data2^));
102			end;
103
104			function MatchStrings(Container : TStContainer;
105			Node : TStNode;
106			OtherData : Pointer) : Boolean; far;
107			{-user defined function to search for strings in a
108			TStList based class. Used by the TStList.Iterate method}
109			begin
110			Result := S10(Node.Data^) <> S10(OtherData^);
111			end;
112
113			procedure MyDelNodeData(Data : pointer); far;
114			{-procedure to delete data pointer in each node
115			during call to TStList.Destroy}
116			begin
117			FreeMem(Data,SizeOf(S10));
118			end;
119
120
121			function MyLoadData(Reader : TReader) : Pointer; far;
122			begin
123			GetMem(Result,SizeOf(S10));
124			S10(Result^) := Reader.ReadString;
125			end;
126
127
128			procedure MyStoreData(Writer : TWriter; Data : Pointer); far;
129			begin
130			Writer.WriteString(S10(Data^));
131			end;
132
133			procedure TSTDlg.FormCreate(Sender: TObject);
134			begin
135			RegisterClasses([TStList,TStListNode]);
136			UpdateButtons(False);
137			end;
138
139
140			procedure TSTDlg.FormClose(Sender: TObject;
141			var Action: TCloseAction);
142			begin
143			MyList.Free;
144			end;
145
146			procedure TSTDlg.SetBusy(B : Boolean);
147			begin
148			if B then
149			Screen.Cursor := crHourGlass
150			else
151			Screen.Cursor := crDefault;
152			end;
153
154			procedure TSTDlg.UpdateButtons(LOK : Boolean);
155			begin
156			ClearBtn.Enabled := LOK;
157			DeleteBtn.Enabled := LOK;
158			HeadBtn.Enabled := LOK;
159			AppendBtn.Enabled := LOK;
160			InsertBtn.Enabled := LOK;
161			InsSortedBtn.Enabled := LOK;
162			PlaceBtn.Enabled := LOK;
163			PlaceBeforeBtn.Enabled := LOK;
164			SortBtn.Enabled := LOK;
165			SaveBtn.Enabled := LOK;
166			end;
167
168			procedure TSTDlg.CreateList;
169			begin
170			UpdateButtons(False);
171			MyList := TStList.Create(TStListNode);
172
173			MyList.Compare := MyCompare;
174			MyList.DisposeData := MyDelNodeData;
175			MyList.LoadData := MyLoadData;
176			MyList.StoreData := MyStoreData;
177			end;
178
179
180			procedure TSTDlg.FillListBox;
181			var
182			PN : TStListNode;
183
184			begin
185			PN := MyList.Head;
186
187			LB1.Clear;
188			LB1.Perform(WM_SETREDRAW,0,0);
189			SetBusy(True);
190
191			while (PN <> nil) do
192			begin
193			LB1.Items.Add(S10(PN.Data^));
194			PN := MyList.Next(PN);
195			end;
196
197			LB1.Perform(WM_SETREDRAW,1,0);
198			LB1.Update;
199			SetBusy(False);
200			end;
201
202
203			procedure TSTDlg.CreateBtnClick(Sender: TObject);
204			var
205			J,
206			step : integer;
207			S : ^S10;
208			begin
209			if Assigned(MyList) then
210			MyList.Free;
211
212			CreateList;
213			Randomize;
214			for step := 1 to MaxElems do
215			begin
216			GetMem(S,SizeOf(S10));
217			S^[0] := Chr(10);
218			for J := 1 to 10 do
219			S^[J] := Chr(random(26) + Ord('A'));
220			MyList.Append(S);
221			end;
222			FillListBox;
223			UpdateButtons(True);
224			end;
225
226
227			procedure TSTDlg.ClearBtnClick(Sender: TObject);
228			begin
229			MyList.Clear;
230			{confirm list was cleared}
231			FillListBox;
232			end;
233
234			procedure TSTDlg.DeleteBtnClick(Sender: TObject);
235			var
236			WhichOne : integer;
237			PN : TStListNode;
238			S : S10;
239			begin
240			WhichOne := LB1.ItemIndex;
241			if (WhichOne < 0) then
242			begin
243			ShowMessage('No item selected');
244			Exit;
245			end;
246
247			S := LB1.Items[WhichOne];
248			PN := MyList.Iterate(MatchStrings,True,@S);
249
250			if (PN <> nil) then
251			begin
252			MyList.Delete(PN);
253			FillListBox;
254			end;
255			end;
256
257			procedure TSTDlg.HeadBtnClick(Sender: TObject);
258			var
259			WhichOne : integer;
260			S : S10;
261			PN : TStListNode;
262			begin
263			WhichOne := LB1.ItemIndex;
264			if (WhichOne < 0) then
265			begin
266			ShowMessage('No item selected');
267			Exit;
268			end;
269
270			S := LB1.Items[WhichOne];
271			PN := MyList.Iterate(MatchStrings,True,@S);
272			if (PN <> nil) then
273			begin
274			MyList.MoveToHead(PN);
275			FillListBox;
276			end;
277			end;
278
279			procedure TSTDlg.AppendBtnClick(Sender: TObject);
280			var
281			S : ^S10;
282			begin
283			if (Edit1.Text = '') then
284			begin
285			ShowMessage('Empty string not allowed');
286			Exit;
287			end;
288			GetMem(S,SizeOf(S10));
289			S^ := Edit1.Text;
290			MyList.Append(S);
291			FillListBox;
292			end;
293
294			procedure TSTDlg.InsertBtnClick(Sender: TObject);
295			var
296			S : ^S10;
297			begin
298			if (Edit1.Text = '') then
299			begin
300			ShowMessage('Empty string not allowed');
301			Exit;
302			end;
303			GetMem(S,SizeOf(S10));
304			S^ := Edit1.Text;
305			MyList.Insert(S);
306			FillListBox;
307			end;
308
309			procedure TSTDlg.InsSortedBtnClick(Sender: TObject);
310			var
311			S : ^S10;
312			begin
313			if (Edit1.Text = '') then
314			begin
315			ShowMessage('Empty string not allowed');
316			Exit;
317			end;
318			GetMem(S,SizeOf(S10));
319			S^ := Edit1.Text;
320			MyList.InsertSorted(S);
321			FillListBox;
322			end;
323
324			procedure TSTDlg.PlaceBtnClick(Sender: TObject);
325			var
326			WhichOne : integer;
327			S : ^S10;
328			PS : S10;
329			PN : TStListNode;
330			begin
331			WhichOne := LB1.ItemIndex;
332			if (WhichOne < 0) then
333			begin
334			ShowMessage('No item selected');
335			Exit;
336			end;
337			if (Edit1.Text = '') then
338			begin
339			ShowMessage('Empty string not allowed');
340			Exit;
341			end;
342			GetMem(S,SizeOf(S10));
343			S^ := Edit1.Text;
344			PS := LB1.Items[WhichOne];
345			PN := MyList.Iterate(MatchStrings,True,@PS);
346			if (PN <> nil) then
347			begin
348			MyList.Place(S,PN);
349			FillListBox;
350			end;
351			end;
352
353			procedure TSTDlg.PlaceBeforeBtnClick(Sender: TObject);
354			var
355			WhichOne : integer;
356			S : ^S10;
357			PS : S10;
358			PN : TStListNode;
359
360			begin
361			WhichOne := LB1.ItemIndex;
362			if (WhichOne < 0) then
363			begin
364			ShowMessage('No item selected');
365			Exit;
366			end;
367			if (Edit1.Text = '') then
368			begin
369			ShowMessage('Empty string not allowed');
370			Exit;
371			end;
372			GetMem(S,SizeOf(S10));
373			S^ := Edit1.Text;
374			PS := LB1.Items[WhichOne];
375			PN := MyList.Iterate(MatchStrings,True,@PS);
376			if (PN <> nil) then
377			begin
378			MyList.PlaceBefore(S,PN);
379			FillListBox;
380			end;
381			end;
382
383			procedure TSTDlg.SortBtnClick(Sender: TObject);
384			begin
385			MyList.Sort;
386			FillListBox;
387			end;
388
389			procedure TSTDlg.LoadBtnClick(Sender: TObject);
390			begin
391			if (OD1.Execute) then
392			begin
393			if (NOT Assigned(MyList)) then
394			CreateList;
395			MyList.Clear;
396			MyList.LoadFromFile(OD1.FileName);
397
398			FillListBox;
399			UpdateButtons(True);
400			end;
401			end;
402
403			procedure TSTDlg.SaveBtnClick(Sender: TObject);
404			begin
405			if (SD1.Execute) then
406			MyList.StoreToFile(SD1.FileName);
407			end;
408
409
410			end.