uses FileCtrl; 
 
const 
  Version: string = '1.0'; 
  versionsfehler: boolean = false; 
  Datei: string = 'Container.str'; 
  ID: integer = 0; 
 
var 
  Container, tmp: TFileStream; 
  groesse, soi: integer; 
  pfad, s: string; 
 
procedure anzeige; 
begin 
  if versionsfehler then 
    Form1.Label1.caption := 'Falsche Version' else 
    Form1.Label1.caption := 'Der Container enthält ' + inttostr(ID) 
      + ' Datei(en)'; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Pfad := ExtractFilePath(Application.ExeName); 
  soi := sizeof(integer); 
  if not FileExists(pfad + datei) then begin 
    Container := TFileStream.Create(pfad + datei, fmCreate); 
    groesse := length(version); 
    Container.Write(groesse, soi); 
    Container.Write(version[1], groesse); 
    Container.Write(ID, soi); 
  end else begin 
    Container := TFileStream.Create(pfad + datei, fmOpenRead); 
    if Container.size < soi * 2 then versionsfehler := true 
    else begin 
      Container.Read(groesse, soi); 
      if Container.size < soi * 2 + groesse then 
        versionsfehler := true else begin 
        setlength(s, groesse); 
        Container.Read(s[1], groesse); 
        if s <> version then versionsfehler := true 
        else begin 
          Container.seek(-soi, soFromEnd); 
          Container.read(ID, soi); 
        end; 
      end; 
    end; 
  end; 
  Container.free; 
  anzeige; 
end; 
 
function schreiben: boolean; 
begin 
  result := false; 
  if Form1.OpenDialog1.Execute then begin 
    application.processmessages; 
    s := ansilowercase(ExtractFileName(Form1.OpenDialog1.FileName)); 
    if FileExists(pfad + datei) then begin 
      Container := TFileStream.Create(Pfad + Datei, fmOpenWrite 
        or fmShareExclusive); 
      Container.seek(0, soFromEnd); 
      groesse := length(s); 
      Container.Write(groesse, soi); 
      Container.Write(s[1], groesse); 
      tmp := TFileStream.Create(Form1.OpenDialog1.FileName, fmOpenRead 
        or fmShareExclusive); 
      groesse := tmp.Size; 
      Container.Write(groesse, soi); 
      Container.CopyFrom(tmp, groesse); 
      tmp.Free; 
      inc(ID); 
      Container.Write(ID, soi); 
      Container.Free; 
      anzeige; 
      result := true; 
    end; 
  end; 
end; 
 
function zuweit: boolean; 
begin 
  result := Container.Position >= Container.Size; 
  if result then Container.free; 
end; 
 
function schonda(dn: string): TModalresult; 
begin 
  if FileExists(dn) then 
    result := Application.Messagebox( 
      'Die Datei existiert bereits. Überschreiben???', 'Problem', 
      MB_YESNOCANCEL or MB_ICONQUESTION) 
  else result := mrYes; 
  if result = mrCancel then Container.free; 
end; 
 
procedure first; 
begin 
  Container := TFileStream.Create(pfad + Datei, fmOpenRead or fmShareExclusive); 
  Container.read(groesse, soi); 
  setlength(s, groesse); 
  Container.read(s[1], groesse); 
end; 
 
procedure last(dn: string); 
begin 
  tmp := TFileStream.Create(dn, fmcreate); 
  tmp.CopyFrom(Container, groesse); 
  tmp.Free; 
end; 
 
procedure lauf; 
begin 
  with Form1 do begin 
    Screen.cursor := crHourGlass; 
    Button1.enabled := false; // im Beispiel werden 6 Buttons verwendet
    Button2.enabled := false; 
    Button3.enabled := false; 
    Button4.enabled := false; 
    Button5.enabled := false; 
    Button6.enabled := false; 
  end; 
  application.processmessages; 
end; 
 
procedure ende; 
begin 
  with Form1 do begin 
    Button1.enabled := true; 
    Button2.enabled := true; 
    Button3.enabled := true; 
    Button4.enabled := true; 
    Button5.enabled := true; 
    Button6.enabled := true; 
    Screen.cursor := crDefault; 
  end; 
end; 
 
procedure erweitern(pfd: string); 
begin 
  while Fileexists(pfd + s) do s := '_' + s; 
end; 
 
function makepath(pfd: string): string; 
begin 
  if ansilastchar(pfd) <> '\' then pfd := pfd + '\'; 
  forcedirectories(pfd); 
  result := pfd; 
end; 
 
function lesen(gesucht: integer; str: TStream): boolean; overload; 
var 
  gefunden, lg: integer; 
begin 
  result := false; 
  if FileExists(pfad + datei) then begin 
    first; 
    if s <> version then versionsfehler := true 
    else begin 
      groesse := 0; 
      str.size := groesse; 
      repeat 
        Container.Position := Container.Position + groesse; 
        if zuweit then exit; 
        Container.read(gefunden, soi); 
        if zuweit then exit; 
        Container.read(lg, soi); 
        if zuweit then exit; 
        setlength(s, lg); 
        Container.read(s[1], lg); 
        Container.read(groesse, soi); 
        if zuweit then exit; 
      until gesucht = gefunden; 
      str.CopyFrom(Container, groesse); 
      str.position := 0; 
      result := true; 
    end; 
    Container.Free; 
    anzeige; 
  end; 
end; 
 
function lesen(gesucht: integer; Zielpfad: string): boolean; overload; 
var 
  gefunden, lg: integer; 
begin 
  result := false; 
  if FileExists(pfad + datei) then begin 
    first; 
    try 
      Zielpfad := makepath(Zielpfad); 
    except 
      Container.free; 
      exit; 
    end; 
    if s <> version then versionsfehler := true 
    else begin 
      groesse := 0; 
      repeat 
        Container.Position := Container.Position + groesse; 
        if zuweit then exit; 
        Container.read(gefunden, soi); 
        if zuweit then exit; 
        Container.read(lg, soi); 
        if zuweit then exit; 
        setlength(s, lg); 
        Container.read(s[1], lg); 
        Container.read(groesse, soi); 
        if zuweit then exit; 
      until gesucht = gefunden; 
      case schonda(Zielpfad + s) of 
        mrCancel: exit; 
        mrNo: erweitern(Zielpfad); 
      end; 
      last(Zielpfad + s); 
      result := true; 
    end; 
    Container.Free; 
    anzeige; 
  end; 
end; 
 
function lesen(gesucht, Zielpfad: string): boolean; overload; 
var 
  lg, d: integer; 
begin 
  result := false; 
  if FileExists(pfad + datei) then begin 
    gesucht := ansilowercase(gesucht); 
    first; 
    try 
      Zielpfad := makepath(Zielpfad); 
    except 
      Container.free; 
      exit; 
    end; 
    if s <> version then versionsfehler := true 
    else begin 
      groesse := 0; 
      repeat 
        Container.Position := Container.Position + groesse; 
        if zuweit then exit; 
        Container.read(d, soi); 
        if zuweit then exit; 
        Container.read(lg, soi); 
        if zuweit then exit; 
        setlength(s, lg); 
        Container.read(s[1], lg); 
        Container.read(groesse, soi); 
        if zuweit then exit; 
      until gesucht = s; 
      case schonda(Zielpfad + s) of 
        mrCancel: exit; 
        mrNo: erweitern(Zielpfad); 
      end; 
      last(Zielpfad + s); 
      result := true; 
    end; 
    Container.Free; 
    anzeige; 
  end; 
end; 
 
function loeschen(gesucht: integer): boolean; overload; 
const dt = '~temp'; 
var 
  gefunden, lg, merk, mID: integer; 
  hlp: TFileStream; 
begin 
  result := false; 
  if FileExists(pfad + datei) then begin 
    Container := TFileStream.Create(pfad + Datei, 
      fmOpenReadWrite or fmShareExclusive); 
    Container.read(groesse, soi); 
    setlength(s, groesse); 
    Container.read(s[1], groesse); 
    if s <> version then versionsfehler := true 
    else begin 
      groesse := 0; 
      repeat 
        Container.Position := Container.Position + groesse; 
        if zuweit then exit; 
        merk := Container.Position; 
        Container.read(gefunden, soi); 
        if zuweit then exit; 
        Container.read(lg, soi); 
        if zuweit then exit; 
        Container.Position := Container.Position + lg; 
        Container.read(groesse, soi); 
        if zuweit then exit; 
      until gesucht = gefunden; 
      mID := gefunden; 
      hlp := TFileStream.create(dt, fmcreate); 
      Container.Position := Container.Position + groesse; 
      hlp.CopyFrom(Container, Container.size - Container.Position); 
      hlp.seek(0, soFromBeginning); 
      Container.Position := merk; 
      Container.CopyFrom(hlp, hlp.size); 
      Container.size := hlp.size + merk; 
      hlp.free; 
      dec(ID); 
      deletefile(dt); 
      Container.Position := merk; 
      groesse := 0; 
      repeat 
        Container.Position := Container.Position + groesse; 
        if zuweit then break; 
        Container.write(mID, soi); 
        inc(mID); 
        if zuweit then break; 
        Container.read(lg, soi); 
        if zuweit then break; 
        Container.Position := Container.Position + lg; 
        Container.read(groesse, soi); 
        if zuweit then break; 
      until false; 
      result := true; 
    end; 
    anzeige; 
  end; 
end; 
 
procedure listen(lines: TStrings); 
var 
  lg, d: integer; 
begin 
  if FileExists(pfad + datei) then begin 
    lines.clear; 
    first; 
    if s <> version then versionsfehler := true 
    else begin 
      groesse := 0; 
      repeat 
        Container.Position := Container.Position + groesse; 
        if zuweit then exit; 
        Container.read(d, soi); 
        if zuweit then exit; 
        Container.read(lg, soi); 
        if zuweit then exit; 
        setlength(s, lg); 
        Container.read(s[1], lg); 
        lines.add(formatfloat('0000  ', d) + s); 
        Container.read(groesse, soi); 
        if zuweit then exit; 
      until false; 
    end; 
    Container.Free; 
    anzeige; 
  end; 
end; 
 
// --- Beispielaufrufe --- 
 
// Eine Datei dem Container hinzufügen 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  lauf; 
  if not schreiben then showmessage('Nicht in den Container geschrieben') 
  else begin 
    showmessage('Schreiben erfolgreich'); 
    Memo1.clear; 
  end; 
  ende; 
end; 
 
// eine Datei anhand der ID im Container suchen und 
// im vorgegebenen Pfad erzeugen 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  lauf; 
  if not lesen(0, 'C:\Container') then showmessage('Datei nicht erzeugt') 
  else showmessage('Datei erfolgreich erzeugt'); 
  ende; 
end; 
 
// eine Datei anhand des Namens im Container suchen und erzeugen 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  lauf; 
  if not lesen('Boerse2.rtf', 'd:\Test') then showmessage('Datei nicht erzeugt') 
  else showmessage('Datei erfolgreich erzeugt'); 
  ende; 
end; 
 
// IDs und Dateinamen des Containers auflisten 
 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  lauf; 
  listen(Memo1.lines); 
  if Memo1.lines.count = 0 then Memo1.lines.add('Container ist leer'); 
  ende; 
end; 
 
// Loeschen einer Datei anhand der ID 
 
procedure TForm1.Button5Click(Sender: TObject); 
begin 
  lauf; 
  if loeschen(4) then begin 
    showmessage('Löschen erfolgreich.'); 
    Memo1.clear; 
  end else showmessage('Fehler beim Löschvorgang'); 
  ende; 
end; 
 
// Lesen anhand einer ID in einen Stream (z.B. Bitmap); 
 
procedure TForm1.Button6Click(Sender: TObject); 
const 
  txt = 'Fehler beim Lesen der Datei'; 
var 
  ms: TMemoryStream; 
  bm: TBitmap; 
begin 
  lauf; 
  bm := TBitmap.create; 
  ms := TMemoryStream.create; 
  if not lesen(5, ms) then showmessage(txt) 
  else try 
    bm.loadfromstream(ms); 
    canvas.draw(0, 0, bm); 
  except 
    showmessage(txt); 
  end; 
  ms.free; 
  bm.free; 
  ende; 
end;