Marco Web Center |
Home: Code Repository: DevNewsProject DIRDEMO
Project StructureDIRDEMO.DPRprogram dirdemo; uses Forms, ddsdemoform in 'ddsdemoform.pas' {Form1}; {$R *.RES} begin Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; end. DDSDEMOFORM.PASunit 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.PASunit 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.PASunit 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.DFMobject 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
|
||
© Copyright Marco Cantù, 1995-2020, All rights reserved |