// TCollection ist ein Datentyp für dynamische Arrays bzw. Records, 
// welche die Größe zur Laufzeit automatisch verändern. Eine weitere 
// Besonderheit ist, dass man die einzelnen Elemente (Items) der 
// Kollektion zum Einen über einen Index, zum Anderen über eine ID 
// ansprechen kann. Sind beispielsweise drei Elemente vorhanden, so 
// hat das erste den Index 0, das zweite den Index 1 und das dritte 
// den Index 2. Die ID entspricht beim Erstellen noch dem Index. Wird aber 
// ein Element gelöscht, sagen wir das zweite, erhält das ehemals dritte 
// jetzt den Index 1, behält aber die ID 2, da IDs im Gegensatz zum Index 
// nie verändert werden. D.h., man kann über die ID  feststellen, 
// ob ein Element vorhanden ist, ob es gelöscht wurde, oder ob es 
// vielleicht noch gar nicht angelegt wurde, während über den Index 
// nur feststellbar ist, ob ein Element vorhanden ist oder nicht. 
// Auch wenn über "Insert" ein Element eingefügt wird, erhält es den Index 
// der Stelle des Einfügens, aber die höchste ID. 
// Ein Element selbst kann mehrere Objekte umfassen.
 

// Getestet mit D4 unter XP

// Beispiel 1:
// Das Beispiel zeigt eine Möglichkeit, wie eine Kollektion 
// angelegt werden kann und wie man sie über den Index oder über die ID 
// ansprechen kann. 

unit Unit1; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Forms, Dialogs, StdCtrls, Controls; 
 
type 
 
 // Objekte eines Elements festlegen
  TCollItem = class(TCollectionItem) 
  private 
    FText: string;   // 1. Objekt
    FIWert: integer; // 2. Objekt
    FRWert: double;  // 3. Objekt
  public 
    constructor create(Coll: TCollection); override; 
    property Text: string read FText write FText; 
    property IWert: integer read FIWert write FIWert; 
    property RWert: double read FRWert write FRWert; 
  end; 
 
 // Kollektion anlegen
  TColl = class(TCollection) 
  private 
    function GetItems(index: integer): TCollItem; 
    procedure SetItems(index: integer; Value: TCollItem); 
  public 
    FID: integer; 
    constructor create; 
    function Add: TCollItem; 
    function Insert(Index: Integer): TCollItem; 
    property Items[index: integer]: TCollItem read GetItems write SetItems; 
  end; 
 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Button2: TButton; 
    Button3: TButton; 
    Label1: TLabel; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure Button3Click(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    { Public-Deklarationen } 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
//  ---  TCollItem -------------------------------- 
 
constructor TCollItem.create(Coll: TCollection); 
begin 
  if assigned(Coll) and (Coll is TColl) then 
    inherited Create(Coll); 
end; 
 
//  ---  TColl ----------------------------------- 
 
constructor TColl.create; 
begin 
  inherited create(TCollItem); 
  FID := -1; 
end; 
 
function TColl.Add: TCollItem; 
begin 
  Result := TCollItem(inherited Add); 
  FID := Result.ID; 
end; 
 
function TColl.Insert(Index: integer): TCollItem; 
begin 
  Result := TCollItem(inherited Insert(Index)); 
  FID := Result.ID; 
end; 
 
function TColl.GetItems(Index: integer): TCollItem; 
begin 
  Result := TCollItem(inherited Items[Index]); 
end; 
 
procedure TColl.SetItems(Index: integer; Value: TCollItem); 
begin 
  Items[Index].Assign(Value); 
end; 
 
//  ---  TForm1  ------------------------------------ 
 
var 
  Coll1: TColl; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Coll1 := TColl.Create; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  Coll1.free; 
end; 
 
//  ---  Beispiel für Index  --------------------------------- 
 
// vier Items hinzufügen 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Label1.Caption := ''; 
  with Coll1 do begin 
    Clear; 
    Add; 
    Items[Count - 1].Text := 'TEST-1'; 
    Items[Count - 1].IWert := 3; 
    Items[Count - 1].RWert := 17.59; 
    Add; 
    Items[Count - 1].Text := 'TEST-2'; 
    Items[Count - 1].IWert := 7; 
    Items[Count - 1].RWert := 0.99; 
    Add; 
    Items[Count - 1].Text := 'TEST-3'; 
    Items[Count - 1].IWert := 21; 
    Items[Count - 1].RWert := 5.3; 
    Insert(1); 
    Items[1].Text := 'Insert-1'; 
    Items[1].IWert := 500; 
    Items[1].RWert := 14.14; 
  end; 
end; 
 
// Der zweite Real-Wert (Index = 1) wird angezeigt und danach der Item gelöscht. 
// (Button1 muss einmal vor Button2 angeklickt worden sein) 
// Beim ertsen Klick auf Button2 erscheint '14,14', 
// beim zweiten Klick '0,99', dann '5,3' 
// und beim vierten 'nicht vorhanden'. 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  idx: integer; 
begin 
  idx := 1; 
  with Coll1 do begin 
    if count > idx then begin 
      Label1.Caption := FloatToStr(Items[idx].RWert); 
      Items[idx].Destroy; 
    end else Label1.Caption := 'nicht vorhanden'; 
  end; 
end; 
 
//  ------------------------------------------------------------ 
 
 
//  ---  ID-Funktionen  ---------------------------------------- 
 
function CAdd(C: TColl; txt: string; iwrt: integer; rwrt: double): integer; 
var 
  i: integer; 
begin 
  with C do begin 
    Add; 
    i := count - 1; 
    Items[i].Text := txt; 
    Items[i].IWert := iwrt; 
    Items[i].RWert := rwrt; 
    Result := FID; 
  end; 
end; 
 
function CInsert(C: TColl; Index: integer; 
  txt: string; iwrt: integer; rwrt: double): integer; 
begin 
  with C do begin 
    Insert(Index); 
    Items[Index].Text := txt; 
    Items[Index].IWert := iwrt; 
    Items[Index].RWert := rwrt; 
    Result := FID; 
  end; 
end; 
 
procedure CDestroy(C: TColl; ID: integer); 
const 
  ci: TCollectionItem = nil; 
begin 
  with C do begin 
    ci := FindItemID(ID); 
    if ci <> nil then items[ci.index].destroy; 
  end; 
end; 
 
function CGetText(C: TColl; ID: integer): string; 
const 
  ci: TCollectionItem = nil; 
begin 
  with C do begin 
    ci := FindItemID(ID); 
    if ci <> nil then Result := items[ci.index].Text 
    else begin 
      if ID > FID then 
        Result := 'nicht vorhanden' 
      else Result := 'gelöscht'; 
    end; 
  end; 
end; 
 
function CGetReal(C: TColl; ID: integer; var rwrt: double): boolean; 
const 
  ci: TCollectionItem = nil; 
begin 
  with C do begin 
    ci := FindItemID(ID); 
    if ci <> nil then begin 
      rwrt := items[ci.index].RWert; 
      Result := true; 
    end else Result := false; 
  end; 
end; 
 
function CGetInteger(C: TColl; ID: integer; var iwrt: integer): boolean; 
const 
  ci: TCollectionItem = nil; 
begin 
  with C do begin 
    ci := FindItemID(ID); 
    if ci <> nil then begin 
      iwrt := items[ci.index].IWert; 
      Result := true; 
    end else Result := false; 
  end; 
end; 
 
//  ---  Beispiel für ID  --------------------------------------- 
 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  id1, id2, idi, x: integer; 
  d: double; 
  Coll2: TColl; 
begin 
  Coll2 := TColl.Create; 
 
  id1 := CAdd(Coll2, 'TEST-1', 3, 17.59); 
  id2 := CAdd(Coll2, 'TEST-2', 7, 0.99); 
         CAdd(Coll2, 'TEST-3', 21, 5.3); 
 
  showmessage(CGetText(Coll2, id1)); // 'TEST-1' 
 
  if not CGetReal(Coll2, maxint, d) then 
    showmessage(CGetText(Coll2, maxint)) // 'nicht vorhanden' 
  else showmessage(FloatToStr(d)); 
 
  showmessage(CGetText(Coll2, id2)); // 'TEST-2' 
 
  if CGetInteger(Coll2, id2, x) then 
    showmessage(inttostr(x)); // '7' 
 
  CDestroy(Coll2, id1); 
  showmessage(CGetText(Coll2, 0)); // 'gelöscht' 
 
  idi := CInsert(Coll2, 1, 'Insert-1', 500, 14.14); 
 
  showmessage(CGetText(Coll2, 1)); // 'TEST-2' 
  showmessage(CGetText(Coll2, 3)); // 'Insert-1' 
 
  CDestroy(Coll2, idi); 
  showmessage(CGetText(Coll2, 3)); // 'gelöscht' 
 
  Coll2.Free; 
end; 
 
end.

unit Unit2; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Forms, Dialogs, StdCtrls, Controls, 
  ExtCtrls, JPeg, Graphics; 
 
type 
 
  TBCollItem = class(TCollectionItem) 
  private 
    FArt: Byte; 
    FText: shortstring; 
    FPicture: TPicture; 
    function readPicture: TGraphic; 
    procedure setPicture(b: TGraphic); 
  public 
    destructor Destroy; override; 
    property Art: Byte read FArt write FArt; 
    property Text: shortstring read FText write FText; 
    constructor create(Collection: TCollection); override; 
    property Bild: TGraphic read readPicture write setPicture; 
  end; 
 
  TBColl = class(TCollection) 
  private 
    versi: string; 
    tfs: TFilestream; 
    function GetItems(index: integer): TBCollItem; 
    procedure SetItems(index: integer; Value: TBCollItem); 
  public 
    constructor create; 
    function GetArt(g: TGraphic): byte; 
    procedure SaveToFile(Dateiname: TFilename); 
    function LoadFromFile(Dateiname: TFilename): boolean; 
    function Add(S: shortstring; Grafik: TGraphic): integer; 
    property Items[index: integer]: TBCollItem read GetItems write SetItems; 
    function Insert(Index: Word; S: shortstring; Grafik: TGraphic): integer; 
    function ChangeByID(ID: integer; S: shortstring; Grafik: TGraphic): boolean; 
    function ChangeByIDX(Index: integer; S: shortstring; Grafik: TGraphic): boolean; 
  end; 
 
  TForm1 = class(TForm) 
    Label1: TLabel; 
    Image1: TImage; 
    Button1: TButton; 
    Button2: TButton; 
    Button3: TButton; 
    Button4: TButton; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure Button2Click(Sender: TObject); 
    procedure Button3Click(Sender: TObject); 
    procedure Button4Click(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    { Public-Deklarationen } 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
const 
  bmp = 1; 
  jpg = 2; 
 
//  ---  TBColl ----------------------------------- 
 
constructor TBColl.create; 
begin 
  inherited create(TBCollItem); 
  versi := 'CoLL' + #1#2#3; // Versionskennung 
end; 
 
function TBColl.GetArt(g: TGraphic): byte; 
begin 
  if g is TBitmap 
    then result := bmp else 
    if g is TJPegImage 
      then result := jpg else 
      result := 0; 
end; 
 
function TBColl.Add(S: shortstring; Grafik: TGraphic): integer; 
var b: Byte; 
begin 
  b := GetArt(Grafik); 
  if not (b in [bmp, jpg]) then begin 
    result := -1; 
    exit; 
  end; 
  inherited add; 
  Items[Count - 1].Text := S; 
  Items[Count - 1].Bild := Grafik; 
  Items[Count - 1].Art := b; 
  result := Items[Count - 1].ID; 
end; 
 
function TBColl.Insert(Index: Word; S: shortstring; Grafik: TGraphic): integer; 
var b: Byte; 
begin 
  b := GetArt(Grafik); 
  if not (b in [bmp, jpg]) then begin 
    result := -1; 
    exit; 
  end; 
  inherited Insert(Index); 
  Items[Index].Text := S; 
  Items[Index].Bild := Grafik; 
  Items[Index].Art := b; 
  result := Items[Index].ID; 
end; 
 
function TBColl.ChangeByID(ID: integer; S: shortstring; Grafik: TGraphic): boolean; 
var ci: TCollectionItem; 
  b: Byte; 
begin 
  result := false; 
  b := GetArt(Grafik); 
  if not (b in [bmp, jpg]) then exit; 
  ci := FindItemID(ID); 
  if ci <> nil then begin 
    Items[ci.Index].Text := S; 
    Items[ci.Index].Bild := Grafik; 
    Items[ci.Index].Art := b; 
    result := true; 
  end; 
end; 
 
function TBColl.ChangeByIDX(Index: integer; S: shortstring; Grafik: TGraphic): boolean; 
var b: Byte; 
begin 
  result := false; 
  b := GetArt(Grafik); 
  if not (b in [bmp, jpg]) then exit; 
  if Index < count then begin 
    Items[Index].Text := S; 
    Items[Index].Bild := Grafik; 
    Items[Index].Art := b; 
    result := true; 
  end; 
end; 
 
function TBColl.GetItems(Index: integer): TBCollItem; 
begin 
  Result := TBCollItem(inherited Items[Index]); 
end; 
 
procedure TBColl.SetItems(Index: integer; Value: TBCollItem); 
begin 
  Items[Index].Assign(Value); 
end; 
 
procedure TBColl.SaveToFile(Dateiname: TFilename); 
var 
  hlp: TBitmap; 
  x, y: integer; 
begin 
  y := count - 1; 
  hlp := TBitmap.create; 
  tfs := TFilestream.create(Dateiname, fmcreate); 
  tfs.writebuffer(versi[1], length(versi)); 
  tfs.writebuffer(y, sizeof(integer)); 
  for x := 0 to y do begin 
    tfs.writebuffer(Items[x].Art, 1); 
    hlp.assign(Items[x].Bild); 
    hlp.savetostream(tfs); 
    tfs.writebuffer(Items[x].Text, sizeof(shortstring)); 
  end; 
  tfs.free; 
  hlp.free; 
end; 
 
function TBColl.LoadFromFile(Dateiname: TFilename): boolean; 
var 
  b: Byte; 
  p: PChar; 
  tbm: TBitmap; 
  x, y: integer; 
  s: shortstring; 
  tjp: TJpegImage; 
  procedure zuweisen; 
  begin 
    case b of 
      1: add(s, tbm); 
      2: begin tjp.assign(tbm); add(s, tjp); end; 
    end; 
  end; 
begin 
  result := false; 
  try 
    tfs := TFileStream.create(Dateiname, fmOpenRead); 
  except 
    tfs.free; 
    exit; 
  end; 
  tbm := TBitmap.create; 
  tjp := TJpegImage.create; 
  x := length(versi); 
  getmem(p, x + 1); 
  tfs.readbuffer(p^, x); 
  if string(p) = versi then begin 
    clear; 
    tfs.readbuffer(y, sizeof(integer)); 
    for x := 0 to y do begin 
      tfs.readbuffer(b, 1); 
      tbm.loadfromstream(tfs); 
      tfs.readbuffer(s[0], sizeof(shortstring)); 
      zuweisen; 
    end; 
    result := true; 
  end; 
  freemem(p); 
  tfs.free; 
  tbm.free; 
  tjp.free; 
end; 
 
//  ---  TBCollItem -------------------------------- 
 
constructor TBCollItem.create(Collection: TCollection); 
begin 
  inherited Create(Collection); 
  FPicture := TPicture.Create; 
end; 
 
destructor TBCollItem.Destroy; 
begin 
  FPicture.Free; 
  inherited Destroy; 
end; 
 
procedure TBCollItem.setPicture(b: TGraphic); 
begin 
  FPicture.assign(b); 
end; 
 
function TBCollItem.readPicture: TGraphic; 
begin 
  result := FPicture.Graphic; 
end; 
 
//  ---  TForm  ------------------------------------ 
 
var 
  BColl1: TBColl; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  BColl1 := TBColl.Create; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  BColl1.free; 
end; 
 
// --- Beispielaufruf --- 
 
// Bilder und Texte hinzufügen, einschieben bzw.ändern 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  id: integer; 
  bm: TBitmap; 
  jp: TJPegImage; 
begin 
  bm := TBitmap.create; 
  jp := TJPegImage.create; 
  jp.loadfromfile('d:\bilder\moneybag.jpg'); 
  bm.loadfromfile('d:\bilder\bingo.bmp'); 
  with BColl1 do begin 
    Clear; 
    id := add('ein Bitmap', bm); 
    insert(0, 'ein Jpeg', jp); 
    add('Weiß nicht', Image1.picture.graphic); 
    add('ein Bitmap', bm); 
    jp.loadfromfile('d:\bilder\klavier.jpg'); 
    ChangeByID(id, 'geändert', jp); 
  end; 
  jp.free; 
  bm.free; 
end; 
 
 
// Bilder der Reihe nach auf Form1 zeichnen, 
// Texte in Label1 anzeigen 
 
var 
  idx: integer = 0; 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  with BColl1 do begin 
    refresh; 
    if count > idx then begin 
      Label1.Caption := Items[idx].Text; 
      canvas.draw(0, 0, Items[idx].Bild); 
      inc(idx); 
    end else begin 
      Label1.Caption := 'nichts mehr da'; 
      idx := 0; 
    end; 
  end; 
end; 
 
// Bilder-Kollektion speichern 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  BColl1.savetofile('C:\test.cll'); 
end; 
 
// Bilder-Kollektion laden 
 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  if not BColl1.loadfromfile('C:\test.cll') 
    then showmessage('FEHLER'); 
end; 
 
end.