Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: DevNews

Project DIRDEMO

Project Structure


DIRDEMO.DPR

program dirdemo;

uses
  Forms,
  ddsdemoform in 'ddsdemoform.pas' {Form1};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

DDSDEMOFORM.PAS

unit ddsdemoform;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, Grids, DBGrids, dirdataset, StdCtrls, FileCtrl;

type
  TForm1 = class(TForm)
    DBGrid1: TDBGrid;
    DataSource1: TDataSource;
    DirectoryListBox1: TDirectoryListBox;
    procedure FormCreate(Sender: TObject);
    procedure DirectoryListBox1Change(Sender: TObject);
  private
    { Private declarations }
  public
    DirDataset: TDirdataSet;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  DirDataset := TDirDataSet.Create (self);
  DataSource1.DataSet := DirDataSet;
  DirectoryListBox1.Directory := 'c:\';
end;

procedure TForm1.DirectoryListBox1Change(Sender: TObject);
begin
  DirDataSet.Close;
  if DirectoryListBox1.Directory <> 'C:\' then
    DirDataSet.Directory := DirectoryListBox1.Directory + '\*.*'
  else
    DirDataSet.Directory := DirectoryListBox1.Directory + '*.*';
  DirDataSet.Open;
end;

end.

CUSTDATASET.PAS

unit custdataset;

interface

uses
  DB, Classes, SysUtils, Windows, Forms, Contnrs;

type
  TListDataSet = class (TDataSet)
  protected
    // record data and status
    FIsTableOpen: Boolean;
    FList: TObjectList;
    FRecordSize: Integer; // actual data + housekeeping
    FCurrent: Integer;
    // dataset virtual methods
    function AllocRecordBuffer: PChar; override;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
    function GetRecordSize: Word; override;
    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
    procedure InternalClose; override;
    procedure InternalDelete; override;
    procedure InternalFirst; override;
    procedure InternalGotoBookmark(Bookmark: Pointer); override;
    procedure InternalHandleException; override;
    procedure InternalLast; override;
    procedure InternalOpen; override;
    procedure InternalPost; override;
    procedure InternalInsert; override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    function IsCursorOpen: Boolean; override;
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
    function GetRecordCount: Integer; override;
    procedure SetRecNo(Value: Integer); override;
    function GetRecNo: Integer; override;
    // for specific subclasses
    procedure ReadListData; virtual; abstract;
  public
    constructor Create (Owner: TComponent); override;
    destructor Destroy; override;

  published
    // redeclared data set properties
    property Active;
    property BeforeOpen;
    property AfterOpen;
    property BeforeClose;
    property AfterClose;
    property BeforeInsert;
    property AfterInsert;
    property BeforeEdit;
    property AfterEdit;
    property BeforePost;
    property AfterPost;
    property BeforeCancel;
    property AfterCancel;
    property BeforeDelete;
    property AfterDelete;
    property BeforeScroll;
    property AfterScroll;
    property OnCalcFields;
    property OnDeleteError;
    property OnEditError;
    property OnFilterRecord;
    property OnNewRecord;
    property OnPostError;
  end;

type
  PRecInfo = ^TRecInfo;
  TRecInfo = record
    Index: Integer;
    Bookmark: Longint;
    BookmarkFlag: TBookmarkFlag;
  end;

implementation

function TListDataSet.AllocRecordBuffer: PChar;
begin
  Result := StrAlloc(fRecordSize);
end;

procedure TListDataSet.InternalInitRecord(Buffer: PChar);
begin
  FillChar(Buffer^, FRecordSize, 0);
end;

procedure TListDataSet.FreeRecordBuffer (var Buffer: PChar);
begin
  StrDispose(Buffer);
end;

procedure TListDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer);
begin
  PInteger(Data)^ := PRecInfo(Buffer).Bookmark;
end;

function TListDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
begin
  Result := PRecInfo(Buffer).BookmarkFlag;
end;

function TListDataSet.GetRecNo: Integer;
begin
  Result := FCurrent + 1;
end;

function TListDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode;
  DoCheck: Boolean): TGetResult;
begin
  Result := grOK; // default
  case GetMode of
    gmNext: // move on
      if fCurrent < fList.Count - 1 then
        Inc (fCurrent)
      else
        Result := grEOF; // end of file
    gmPrior: // move back
      if fCurrent > 0 then
        Dec (fCurrent)
      else
        Result := grBOF; // begin of file
    gmCurrent: // check if empty
      if fCurrent >= fList.Count then
        Result := grEOF;
  end;

  if Result = grOK then // read the data
    with PRecInfo(Buffer)^ do
    begin
      Index := fCurrent;
      BookmarkFlag := bfCurrent;
      Bookmark := fCurrent;
    end;
end;

function TListDataSet.GetRecordCount: Integer;
begin
  Result := FList.Count;
end;

function TListDataSet.GetRecordSize: Word;
begin
  Result := 4; // actual data without house-keeping
end;

procedure TListDataSet.InternalAddRecord(Buffer: Pointer;
  Append: Boolean);
begin
  // todo: support adding items
end;

procedure TListDataSet.InternalClose;
begin
  // disconnet and destroy field objects
  BindFields (False);
  if DefaultFields then
    DestroyFields;
  // closed
  FIsTableOpen := False;
end;

procedure TListDataSet.InternalDelete;
begin
  // todo: support deleting
end;

procedure TListDataSet.InternalFirst;
begin
  FCurrent := 0;
end;

procedure TListDataSet.InternalGotoBookmark(Bookmark: Pointer);
begin
  if (Bookmark <> nil) then
    FCurrent := Integer (Bookmark);
end;

procedure TListDataSet.InternalHandleException;
begin
  Application.HandleException(Self);
end;

procedure TListDataSet.InternalInsert;
begin
  // todo: support deleting
end;

procedure TListDataSet.InternalLast;
begin
  FCurrent := FList.Count - 1;
end;

procedure TListDataSet.InternalOpen;
begin
  // initialize field definitions and create fields
  InternalInitFieldDefs;
  if DefaultFields then
    CreateFields;
  BindFields (True);

  // read directory data
  ReadListData;

  // initialize
  FRecordSize := sizeof (TRecInfo);
  FCurrent := -1;
  BookmarkSize := sizeOf (Integer);
  FIsTableOpen := True;
end;

procedure TListDataSet.InternalPost;
begin

end;

procedure TListDataSet.InternalSetToRecord(Buffer: PChar);
begin
  FCurrent := PRecInfo(Buffer).Index;
end;

function TListDataSet.IsCursorOpen: Boolean;
begin
  Result := FIsTableOpen;
end;

procedure TListDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer);
begin
  PRecInfo(Buffer).Bookmark := PInteger(Data)^;
end;

procedure TListDataSet.SetBookmarkFlag(Buffer: PChar;
  Value: TBookmarkFlag);
begin
  PRecInfo(Buffer).BookmarkFlag := Value;
end;

procedure TListDataSet.SetRecNo(Value: Integer);
begin
  if (Value < 0) or (Value > FList.Count) then
    raise Exception.Create ('SetRecNo: out of range');
  FCurrent := Value - 1;
end;

constructor TListDataSet.Create(Owner: TComponent);
begin
  inherited;
  FList := TObjectList.Create (True); // owns objects
end;

destructor TListDataSet.Destroy;
begin
  inherited;
  FList.Free;
end;

end.

DIRDATASET.PAS

unit dirdataset;

interface

uses
  SysUtils, Classes, Db, custdataset;

type
  TDirDataset = class(TListDataSet)
  private
    FDirectory: string;
    procedure SetDirectory(const NewDirectory: string);
  protected
    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
    procedure InternalInitFieldDefs; override;
    procedure InternalInsert; override;
    procedure InternalPost; override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    procedure ReadListData; override;
    function GetCanModify: Boolean; override;
  public
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
  published
    property Directory: string read FDirectory write SetDirectory;
  end;

  TFileData = class
  public
    ShortFileName: string;
    Time: TDateTime;
    Size: Integer;
    Attr: Integer;
    constructor Create (var FileInfo: TSearchRec);
  end;

implementation

uses
  TypInfo, Dialogs, Windows, Forms, Controls, fileCtrl;

////////////////////////
// File Handling Support

procedure TDirDataset.SetDirectory(const NewDirectory: string);
begin
  if FIsTableOpen then
      raise Exception.Create ('Cannot change directory while dataset is open');
  fDirectory := NewDirectory;
end;

procedure TDirDataSet.ReadListData;
var
  Attr: Integer;
  FileInfo: TSearchRec;
  FileData: TFileData;
begin
  // scan all files
  Attr := faAnyFile;
  FList.Clear;
  if SysUtils.FindFirst(fDirectory, Attr, FileInfo) = 0 then
  repeat
    FileData := TFileData.Create (FileInfo);
    FList.Add (FileData);
  until SysUtils.FindNext(FileInfo) <> 0;
  SysUtils.FindClose(FileInfo);
end;

procedure TDirDataset.InternalInitFieldDefs;
begin
  // TODO: set proper exception...
  if fDirectory = '' then
    raise Exception.Create ('Missing directory');

  // field definitions
  FieldDefs.Clear;
  FieldDefs.Add ('FileName', ftString, 40, True);
  FieldDefs.Add ('TimeStamp', ftDateTime);
  FieldDefs.Add ('Size', ftInteger);
  FieldDefs.Add ('Attributes', ftString, 3);
  FieldDefs.Add ('Folder', ftBoolean);
end;

procedure TDirDataset.InternalPost;
begin
  // TODO: support editing
end;

procedure TDirDataset.InternalAddRecord(Buffer: Pointer; Append: Boolean);
begin
  // TODO: support adding
end;

  function DateTimeToNative(DataType: TFieldType; Data: TDateTime): TDateTimeRec;
  var
    TimeStamp: TTimeStamp;
  begin
    TimeStamp := DateTimeToTimeStamp(Data);
    case DataType of
      ftDate: Result.Date := TimeStamp.Date;
      ftTime: Result.Time := TimeStamp.Time;
    else
      Result.DateTime := TimeStampToMSecs(TimeStamp);
    end;
  end;


function TDirDataset.GetFieldData (
  Field: TField; Buffer: Pointer): Boolean;
var
  FileData: TFileData;
  Bool1: WordBool;
  strAttr: string;
  t: TDateTimeRec;
begin
  FileData := fList [PRecInfo(ActiveBuffer).Index] as TFileData;
  case Field.Index of
    0: // filename
      StrCopy (Buffer, pchar(FileData.ShortFileName));
    1: // timestamp
    begin
      t := DateTimeToNative (ftdatetime, FileData.Time);
      Move (t, Buffer^, sizeof (TDateTime));
    end;
    2:  // size
      Move (FileData.Size, Buffer^, sizeof (Integer));
    3: begin // attributes
      strAttr := '   ';
      if (FileData.Attr and SysUtils.faReadOnly) > 0 then
        strAttr [1] := 'R';
      if (FileData.Attr and SysUtils.faSysFile) > 0 then
        strAttr [2] := 'S';
      if (FileData.Attr and SysUtils.faHidden) > 0 then
        strAttr [3] := 'H';
      StrCopy (Buffer, pchar(strAttr));
    end;
    4: begin // folder
      Bool1 := FileData.Attr and SysUtils.faDirectory > 0;
      Move (Bool1, Buffer^, sizeof (WordBool));
    end;
  end; // case
  Result := True;
end;

// III: Move data from field to record buffer
procedure TDirDataset.SetFieldData(Field: TField; Buffer: Pointer);
begin
  // todo: support changes
end;

procedure TDirDataset.InternalInsert;
begin
  // todo: support inserting
end;

function TDirDataset.GetCanModify: Boolean;
begin
  Result := False; // read-only
end;

{ TFileData }

constructor TFileData.Create(var FileInfo: TSearchRec);
begin
  ShortFileName := FileInfo.Name;
  Time := FileDateToDateTime (FileInfo.Time);
  Size := FileInfo.Size;
  Attr := FileInfo.Attr;
end;

end.

DDSDEMOFORM.DFM

object Form1: TForm1
  Left = 229
  Top = 113
  Width = 695
  Height = 243
  Caption = 'DirDataSet Demo'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object DBGrid1: TDBGrid
    Left = 145
    Top = 0
    Width = 542
    Height = 216
    Align = alClient
    DataSource = DataSource1
    Font.Charset = ANSI_CHARSET
    Font.Color = clWindowText
    Font.Height = -12
    Font.Name = 'Courier New'
    Font.Style = []
    ParentFont = False
    TabOrder = 0
    TitleFont.Charset = DEFAULT_CHARSET
    TitleFont.Color = clWindowText
    TitleFont.Height = -11
    TitleFont.Name = 'MS Sans Serif'
    TitleFont.Style = []
  end
  object DirectoryListBox1: TDirectoryListBox
    Left = 0
    Top = 0
    Width = 145
    Height = 216
    Align = alLeft
    ItemHeight = 16
    TabOrder = 1
    OnChange = DirectoryListBox1Change
  end
  object DataSource1: TDataSource
    AutoEdit = False
    Left = 80
    Top = 168
  end
end