Title: Using TList's and Pointers in delphi (Part II)
Question: This is a nice demonstration of how to create records on a TList object.
It creates and manages a list of Pointers to TMammal record instances.
Answer:
{-----------------------------------------------------------------------------
Unit Name: Unit1
Creation Date: 10-September-2003 22:12:59
Documentation Date: 10-September-2003 22:12:59
Version: 1.0
Keywords: Generic, Tlist, Pointers
Description:
This is a demonstration of how to create records on a TList object.
It creates a list of Pointers to TMammal record instances.
TMammal = record
TType: string;
Hair: string;
speak: string;
end;
Note the Speak element in this record.
In a later demo I will show how to do this with objects stored on a TList.
The TType is either "Human" or "Dog"
Integers but they could be a list of pointers
to any record or class type.
At the end of this is the source for the DFM file used to run this application.
(It just needs to be bound into a project)
Notes:
If there are any terms or concepts in this demo you don't understand please
ask me.
Dependancies:
Compiler version:
History:
Copyright 2003 by Stewart Moss
All rights reserved.
-----------------------------------------------------------------------------}
unit Unit1;
interface
uses
Windows, Messages, sysutils, Variants, classes, Graphics, Controls, forms,
Dialogs, StdCtrls;
type
PMammal = ^TMammal;
TMammal = record
TType: string;
Hair: string;
speak: string;
end;
TForm1 = class(TForm)
btnAdd: TButton;
btnDelete: TButton;
ListBox1: TListBox;
Button1: TButton;
GroupBox1: TGroupBox;
Label1: TLabel;
Label2: TLabel;
lblType: TLabel;
Label4: TLabel;
lblSpeak: TLabel;
lblHair: TLabel;
Label7: TLabel;
Button2: TButton;
Label3: TLabel;
lblIndex: TLabel;
Button3: TButton;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure btnAddClick(Sender: TObject);
procedure btnDeleteClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
MammalList: TList;
function FindMammalByIndex(Index: integer): PMammal;
procedure FreeList;
procedure showlist;
procedure DeleteMammalAtIndex(Index: integer);
procedure ClearGroupBox;
public
function GetRandomHair: string;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
MammalList := TList.create;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FreeList;
MammalList.Free;
end;
procedure TForm1.FreeList;
{-----------------------------------------------------------------------------
Procedure: TForm1.FreeList
Author: Stewart Moss
Date: 20-Jan-2003
This disposes of all the existing items in the list.
** Very important you can't just free the TList object and expect **
** everything else to disappear **
This is optimized to always delete the last item on the list.
It gives the memory manager less work to do!
* tx delphi300.com :)
-----------------------------------------------------------------------------}
var
loop: integer;
tmpcount: integer;
begin
tmpcount := MammalList.Count - 1;
for loop := tmpcount downto 0 do
begin
dispose(MammalList.Items[loop]);
MammalList.Delete(loop);
end;
end;
procedure TForm1.btnAddClick(Sender: TObject);
{-----------------------------------------------------------------------------
Procedure: TForm1.btnAddClick
Arguments: Sender: TObject
Result: None
Date: 10-September-2003 22:19:22
Description:
Creates a new record and stores it in the Pointer Reference "APMammal".
One of the benifits of using objects is you don't have to know how
big the object is to create it.
Copyright 2003 by Stewart Moss
All rights reserved.
-----------------------------------------------------------------------------}
var
APMammal: PMammal;
begin
randomize; // hehehe
// Create and assign memory to a new TMammal record and store it's pointer
new(APMammal);
// Now we choose a random dog or human and set the values
with APMammal^ do
begin
case random(2) of
0: // Human
begin
// if it wasn't for "with APMammal^ do" then these
// lines would read.
// APMammal^.TType := 'Human';
// APMammal^.Hair := 'Blonde';
// APMammal^.speak := 'Hello!';
//
// "APMammal^." is called "dereferencing the pointer"
//
// You are basically saying:
// set (or get) the value of the item (eg Hair) at the pointer
// address held in APMammal.
TType := 'Human';
Hair := GetRandomHair;
speak := 'Hello!';
end;
1: // Dog
begin
TType := 'Dog';
Hair := GetRandomHair;
speak := 'Woof Woof!';
end;
end; // case
end; // with
// Now add this pointer to the TList
// This returns the index position of the item (ie where it is added to the list)
// We don't need it.
//
// More correct is
// Indexpos := MammalList.add(APMammal);
MammalList.add(APMammal);
showlist;
end;
procedure TForm1.showlist;
{-----------------------------------------------------------------------------
Procedure: TForm1.showlist
Author: Stewart Moss
Date: 20-Jan-2003
PInteger(MammalList.Items[loop])^ returns the integer value stored at the
Integer Pointer in the List (de-reference).
Note:
This time I have "type-casted" the generic pointer. I have
prefered not to use a temporary variable called "APMammal" again.
This saves on memory management when accessing more than one property.
An in-efficient (but clearer) method is
var
loop: integer;
APMammal:PMammal;
begin
ListBox1.Items.Clear;
for loop := 0 to MammalList.Count - 1 do
begin
APMammal := PMammal(MammalList.Items[loop])^;
ListBox1.Items.add(IntTostr(loop) + ' - ' + PMammal(APMamal.TType);
end;
end;
-----------------------------------------------------------------------------}
var
loop: integer;
begin
try // cheap trick to swallow un-wanted exceptions
ListBox1.Items.Clear;
for loop := 0 to MammalList.Count - 1 do
begin
ListBox1.Items.add(IntTostr(loop) + ' - ' +
PMammal(MammalList.Items[loop])^.TType);
end; // for
// Select the last item in the TList
ListBox1.ItemIndex := ListBox1.Items.Count - 1;
// Call the Listbox1 click event, to update the groupbox by retreiving the record
// from the list
ListBox1Click(Self);
except // See I don't trap anything here:
// clear the group box
ClearGroupBox;
end; // I have been a bad boy!
end;
procedure TForm1.btnDeleteClick(Sender: TObject);
var
tmpstr: string;
tmpint: integer;
begin
// User has to enter the index of the item to delete (ie remove from the list)
tmpstr := Inputbox('Delete an item out of the list',
'Which item do you want to delete (0=first) ?', '');
if tmpstr = '' then
Exit;
try
tmpint := StrToInt(Trim(tmpstr));
except
raise exception.create(tmpstr + ' is not an integer!');
end;
// Now delete it
DeleteMammalAtIndex(tmpint);
showlist;
// showmessage('Deleted Item Index ' + IntTostr(Index));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
showlist;
end;
function TForm1.FindMammalByIndex(Index: integer): PMammal;
(*-----------------------------------------------------------------------------
Procedure: TForm1.FindMammalByIndex
Arguments: Index: integer
Date: 10-September-2003 22:41:35
Description:
This returns the TMammal record stored at position Index
in the TList.
It traps any exceptions caused by selecting records out of range.
Copyright 2003 by Stewart Moss
All rights reserved.
-----------------------------------------------------------------------------*)
begin
// Turn on the range exception
{R+}
try
result := PMammal(MammalList.Items[Index]);
except
on e: ERangeError do
begin
raise exception.create('Cannot retrieve record at position ' + IntTostr(Index));
end;
end;
{$R-}
end;
procedure TForm1.ListBox1Click(Sender: TObject);
var
APMammal: PMammal;
begin
// Find the currently selected Index in the Listbox.
// And use this to point to the TList
APMammal := FindMammalByIndex(ListBox1.ItemIndex);
with APMammal^ do
begin
lblType.caption := TType;
lblHair.caption := Hair;
lblSpeak.caption := speak;
lblIndex.caption := IntTostr(ListBox1.ItemIndex);
end; // with
end;
function TForm1.GetRandomHair: string;
begin
case random(5) of
0: result := 'Blonde';
1: result := 'Brown';
2: result := 'Blue';
3: result := 'Black';
4: result := 'Red';
end; // case
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.DeleteMammalAtIndex(Index: integer);
begin
if Index MammalList.Count - 1 then
raise exception.create('Number too high!');
dispose(MammalList.Items[Index]); // Free it's memory
MammalList.Delete(Index); // and remove from list
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
try
DeleteMammalAtIndex(ListBox1.ItemIndex);
showlist;
except
// clear the group box
ClearGroupBox;
end;
end;
procedure TForm1.ClearGroupBox;
begin
lblType.caption := '';
lblHair.caption := '';
lblSpeak.caption := '';
lblIndex.caption := '';
end;
end.
{
Unit1.DFM
----------
object Form1: TForm1
Left = 168
Top = 106
Width = 284
Height = 412
Caption = 'Stewart Moss TList Example II'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnClose = FormClose
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 24
Top = 12
Width = 193
Height = 13
Caption = 'Nice and dirty record TList demonstration'
end
object btnAdd: TButton
Left = 24
Top = 61
Width = 75
Height = 25
Caption = 'Add'
TabOrder = 0
OnClick = btnAddClick
end
object btnDelete: TButton
Left = 104
Top = 31
Width = 75
Height = 25
Caption = 'Delete Prompt'
TabOrder = 1
OnClick = btnDeleteClick
end
object ListBox1: TListBox
Left = 28
Top = 92
Width = 217
Height = 109
ItemHeight = 13
TabOrder = 2
OnClick = ListBox1Click
end
object Button1: TButton
Left = 184
Top = 61
Width = 75
Height = 25
Caption = 'Refresh'
TabOrder = 3
OnClick = Button1Click
end
object GroupBox1: TGroupBox
Left = 24
Top = 208
Width = 221
Height = 137
Caption = ' Object Properties '
TabOrder = 4
object Label2: TLabel
Left = 53
Top = 50
Width = 24
Height = 13
Caption = 'Type'
end
object lblType: TLabel
Left = 105
Top = 50
Width = 36
Height = 13
Caption = ''
end
object Label4: TLabel
Left = 50
Top = 74
Width = 31
Height = 13
Caption = 'Speak'
end
object lblSpeak: TLabel
Left = 105
Top = 74
Width = 36
Height = 13
Caption = ''
end
object lblHair: TLabel
Left = 105
Top = 98
Width = 36
Height = 13
Caption = ''
end
object Label7: TLabel
Left = 39
Top = 98
Width = 52
Height = 13
Caption = 'Hair Colour'
end
object Label3: TLabel
Left = 52
Top = 26
Width = 26
Height = 13
Caption = 'Index'
end
object lblIndex: TLabel
Left = 105
Top = 26
Width = 36
Height = 13
Caption = ''
end
end
object Button2: TButton
Left = 196
Top = 352
Width = 75
Height = 25
Caption = 'E&xit'
TabOrder = 5
OnClick = Button2Click
end
object Button3: TButton
Left = 105
Top = 61
Width = 75
Height = 25
Caption = 'Delete'
TabOrder = 6
OnClick = Button3Click
end
end
}