この発言に対し以下のコメントが寄せられています

#01296　らせん企画      さん　RE:レコード型をTListで管理する






　TList を上書きして作ったレコード型を管理するクラスのサンプルです。
　おかしなところがあればご指摘ください。添削歓迎します。
  (#01293 はバグありのため削除しました。(Record の定義がstringのままだった)
   長文を落としてしまわれた方、すいませんでした。)

{使用例  後述のクラスをusesするなどし、あとはTStringListと基本的に同じ}
procedure TForm1.Button1Click(Sender: TObject);
var
  AList: TAddList;
      a: TAddress;
    Cnt: integer;
begin
  AList := TAddList.Create('E:\Bin');
  try
    AList.LoadFromFile;                //ファイル読み込み
    a.Age := 20;
    a.Name := '青木';
    AList.Add(a);                      //データ追加
    Cnt := AList.Find('青木');         //名前で検索
    if Cnt >= 0 then begin
      with AList[Cnt] do Label1.Caption := Format('%s %2d',[Name,Age]);
      a.Age := 100;
      a.Name := '山田';
      AList[Cnt] := a;                 //データ内容変更
      with AList[Cnt] do Label2.Caption := Format('%s %2d',[Name,Age]);
      AList.Delete(Cnt);               //データ削除
    end;
    AList.SaveToFile;                  //ファイル保存
  finally
    AList.Free;
  end;
end;

                                           YRL06713 リービ
//------------------------------------------------------------

interface
uses SysUtils, Classes;

type

  TAddress = packed record
    Name : array[0..19] of char;  //string を使うと保存時などにテクがいる。
    Age  : integer;
  end;

  TADDList = class(TList)
  private
    FFileName: TFileName;
    function GetData(Index: integer): TAddress;
    procedure IdxError(Index: integer);
    procedure PutDate(Index: Integer; const Value: TAddress);
  public
    constructor Create(const Dir: string);
    destructor Destroy; override;
    function Add(Data: TAddress): Integer;
    procedure Clear; override;
    procedure Delete(Index: Integer);
    function Find(const Name: string): Integer;
    procedure LoadFromFile;
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToFile;
    procedure SaveToStream(Stream: TStream);
    property FileName: TFileName read FFileName;
    property Data[Index: Integer]:TAddress read GetData write PutDate;
default;
  published
  end;

implementation

{ TADDList }
const
  SizeOfRec = SizeOf(TAddress);
  FName = 'ADDRESS.DAT';           //ファイル名固定
type
  PREC = ^TAddress;

function TAddList.Add(Data: TAddress): Integer;
var NewData:PREC;
begin
  New(NewData);
  System.Move( Data, NewData^, SizeOf(Data) ); //これでＯＫですよね？
  result := inherited Add(NewData);
end;

procedure TAddList.Clear;
var  i:integer;
begin
  for i:=0 to Count-1 do Dispose( PREC(Items[i]) );
  inherited Clear;
end;

constructor TAddList.Create(const Dir: string);
begin
  FFileName := Dir + '\' + FName; //DirectoryExists と最後の'\'ノーチェック
  inherited Create;
end;

procedure TAddList.Delete(Index: Integer);
begin
  idxError(Index);
  Dispose( PREC(Items[Index]) );
  inherited Delete(Index);
end;

destructor TAddList.Destroy;
begin
  inherited Destroy;
end;
                           //名前で検索 データ重複には未対応
function TAddList.Find(const Name: string): Integer;
begin
  result := -1;
  repeat inc(result);
  until (result=Count) or (PRec(Items[result])^.Name = Name);
  if result = Count then result := -1;
end;

function TAddList.GetData(Index: integer): TAddress;
begin
  idxError(Index);
  Result := TAddress(Items[Index]^);
end;

procedure TAddList.IdxError(Index: integer);
begin
  if (Index < 0) or (Index >= Count) then
    raise Exception.Create('インデックスがリストの範囲を超えています。');
end;

procedure TAddList.PutDate(Index: Integer; const Value: TAddress);
begin
  idxError(Index);
  TAddress(Items[Index]^) := Value;
end;

procedure TAddList.LoadFromFile;
var Stream: TFileStream;
begin
  if not FileExists(FileName) then exit;
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TAddList.LoadFromStream(Stream: TStream);
var tmp: TAddress;
begin
  Clear;
  while Stream.Position < Stream.Size do begin
    Stream.ReadBuffer(tmp, SizeOfRec);
    Add(tmp);
  end;
end;

procedure TAddList.SaveToFile;
var Stream: TFileStream;
begin
  if Count = 0 then exit;
  Stream := TFileStream.Create(FileName, fmCreate or fmShareDenyWrite);
  try                                  //常に上書保存
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TAddList.SaveToStream(Stream: TStream);
var
  i: Integer;
  tmp: TAddress;
begin
  for i:=0 to Count-1 do begin
    tmp := GetData(i);
    Stream.WriteBuffer(tmp, SizeOfRec);
  end;
end;

 



Original document by リービ          氏 ID:(YRL06713)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。