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
|
Home:
Code Repository:
DevNews