Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue52/System/UFileSys.pas

Pascal/Delphi Source File | 1999-10-29 | 17.7 KB | 550 lines

unit UFileSys;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Grids, ExtCtrls;

type
  TForm1 = class(TForm)
    DriveList: TComboBox;
    Label1: TLabel;
    VolSize: TLabel;
    VolName: TLabel;
    FSystem: TLabel;
    SerNum: TLabel;
    DrvType: TLabel;
    FreeSp: TLabel;
    Bevel1: TBevel;
    FolderList: TComboBox;
    Label2: TLabel;
    Label16: TLabel;
    CurFolder: TEdit;
    GroupBox1: TGroupBox;
    cbHidden: TCheckBox;
    cbSystem: TCheckBox;
    cbReadOnly: TCheckBox;
    cbArchive: TCheckBox;
    FileList: TListBox;
    FileCount: TLabel;
    TotFileSize: TLabel;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure DriveListChange(Sender: TObject);
    procedure FolderListChange(Sender: TObject);
    procedure CurFolderKeyPress(Sender: TObject; var Key: Char);
    procedure cbReadOnlyClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    DirSize: TLargeInteger;
    function FormatBigBytes (const Msg: String; Value: TLargeInteger): String;
    procedure UpdateFolderList (const FolderName: String);
    procedure SumProc (const Name: String; const Info: TSearchRec; var Continue: Boolean);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
    EFileSystem = class (Exception);

    TDriveType  = ( fsUnknown, fsNoRoot, fsRemovable, fsFixed, fsRemote, fsCDROM, fsRAMDisk );
    TDriveTypes = set of TDriveType;

    TFileType   = ( ftReadOnly, ftHidden, ftSystem, ftArchive );
    TFileTypes  = set of TFileType;

    TWalkProc = procedure (const Name: String; const Info: TSearchRec; var Continue: Boolean) of Object;

    TFileSystem = class (TComponent)
    private
        fDriveLetter: Char;
        fSerialNumber: DWord;
        fDriveType: TDriveType;
        fDriveTypes: TDriveTypes;
        fFileTypes: TFileTypes;
        fFolders: TStringList;
        fFiles: TStringList;
        fFolderName: String;
        fFileSystem, fDrives, fVolumeName: String;
        fTotalSize, fTotalFileSize, fAvailableSpace, fFreeSpace: TLargeInteger;
        procedure FileWalker (const Folder: String; Proc: TWalkProc; var Continue: Boolean);
        procedure FolderWalker (const Folder: String; Proc: TWalkProc; var Continue: Boolean);
        procedure InitDrivesList;
        procedure RefreshFolderAndFileList;
        function GetDriveCount: Integer;
        function GetIsReady: Boolean;
        function MatchingFile (Rec: TSearchRec): Boolean;
        procedure SetDriveLetter (Value: Char);
        function GetDriveChar (Index: Integer): Char;
        function GetUsedSpace: TLargeInteger;
        function GetSerialNumber: String;
        procedure SetFolderName (Value: String);
        procedure SetVolumeName (Value: String);
        procedure SetDriveTypes (Value: TDriveTypes);
        procedure SetFileTypes (Value: TFileTypes);
    public
        constructor Create (AOwner: TComponent); override;
        destructor Destroy; override;
        procedure Refresh;
        procedure TreeWalkFiles (Proc: TWalkProc);
        procedure TreeWalkFolders (Proc: TWalkProc);
        class function DirectoryExists (const DirName: String): Boolean;
        property Drives [Index: Integer]: Char read GetDriveChar;
        property Folders: TStringList read fFolders;
        property Files: TStringList read fFiles;
    published
        // File-specific stuff
        property TotalFileSize: TLargeInteger read fTotalFileSize;
        property FileTypes: TFileTypes read fFileTypes write SetFileTypes default [ftArchive];
        // Folder-specific stuff
        property FolderName: String read fFolderName write SetFolderName;
        // Drive-specific stuff....
        property DriveLetter: Char read fDriveLetter write SetDriveLetter;
        property DriveType: TDriveType read fDriveType;
        property IsReady: Boolean read GetIsReady;
        property VolumeName: String read fVolumeName write SetVolumeName;
        property FileSystem: String read fFileSystem;
        property SerialNumber: String read GetSerialNumber;
        property SerialNum: DWord read fSerialNumber;
        property TotalSize: TLargeInteger read fTotalSize;
        property FreeSpace: TLargeInteger read fFreeSpace;
        property UsedSpace: TLargeInteger read GetUsedSpace;
        property AvailableSpace: TLargeInteger read fAvailableSpace;
        property DriveCount: Integer read GetDriveCount;
        property DriveTypes: TDriveTypes read fDriveTypes write SetDriveTypes default [fsFixed];
    end;

{ TFileSystem }

constructor TFileSystem.Create (AOwner: TComponent);
begin
    Inherited Create (AOwner);
    fFolders := TStringList.Create;
    fFiles := TStringList.Create;
    fFileTypes := [ftArchive];
    fFolders.Sorted := True;
    fFiles.Sorted := True;
    SetDriveTypes ([fsFixed]);
end;

destructor TFileSystem.Destroy;
begin
    fFolders.Free;
    fFiles.Free;
    Inherited Destroy;
end;

function TFileSystem.GetDriveCount: Integer;
begin
    Result := Length (fDrives);
end;

function TFileSystem.GetDriveChar (Index: Integer): Char;
begin
    Result := #0;
    if (Index >= 0) and (Index < Length (fDrives)) then Result := fDrives [Index + 1];
end;

procedure TFileSystem.InitDrivesList;
var
    p: PChar;
    Buff: array [0..255] of Char;
begin
    fDrives := '';
    GetLogicalDriveStrings (sizeof (Buff), Buff);
    p := Buff;
    while p^ <> #0 do begin
        if TDriveType (GetDriveType (p)) in fDriveTypes then begin
            fDrives := fDrives + UpperCase (p^);
            // If this is the first, make it the current drive by default.
            if Length (fDrives) = 1 then SetDriveLetter (p^);
        end;

        Inc (p, 4);
    end;
end;

function TFileSystem.GetUsedSpace: TLargeInteger;
begin
    Result := fTotalSize - fFreeSpace;
end;

function TFileSystem.GetSerialNumber: String;
begin
    // Precision specifier in the format string ensures that leading zeroes
    // actrually get printed instead of being silently discarded....
    Result := Format ('%.4x-%.4x', [HiWord (fSerialNumber), LoWord (fSerialNumber)]);
end;

procedure TFileSystem.SetDriveLetter (Value: Char);
begin
    Value := UpCase (Value);
    if (Value <> fDriveLetter) and (Pos (Value, fDrives) > 0) then begin
        fDriveLetter := Value;
        fDriveType := TDriveType (GetDriveType (PChar (Value + ':\')));
        Refresh;
    end;
end;

function TFileSystem.GetIsReady: Boolean;
var
    errMode, FindErr: Integer;
    SearchRec: TSearchRec;
begin
    Result := fDriveType in [fsFixed, fsRemote, fsRAMDisk];
    if not Result then begin
        errMode := SetErrorMode (sem_FailCriticalErrors);
        try
            FindErr := FindFirst (fDriveLetter + ':\', faAnyFile, SearchRec);
            try
                Result := FindErr = 2;
            finally
                FindClose (SearchRec);
            end;
        finally
            SetErrorMode (errMode);
        end;
    end;
end;

procedure TFileSystem.SetDriveTypes (Value: TDriveTypes);
begin
    if Value <> fDriveTypes then begin
        fDriveTypes := Value;
        InitDrivesList;
    end;
end;

procedure TFileSystem.Refresh;
var
    Junk: DWord;
    szVolumeName, szFileSystem: array [0..255] of char;
begin
    // Initialise drive-information properties
    if not GetIsReady then raise EFileSystem.Create ('Drive not ready');
    GetDiskFreeSpaceEx (PChar (fDriveLetter + ':\'), fAvailableSpace, fTotalSize, @fFreeSpace);
    GetVolumeInformation (PChar (fDriveLetter + ':\'), szVolumeName, sizeof (szVolumeName),
                          @fSerialNumber, Junk, Junk, szFileSystem, sizeof (szFileSystem));
    fVolumeName := szVolumeName;
    fFileSystem := szFileSystem;
    SetFolderName ('');
end;

procedure TFileSystem.SetVolumeName (Value: String);
begin
    if GetIsReady and (fVolumeName <> Value) then begin
        if Length (Value) > 11 then Value := Copy (Value, 1, 11);
        SetVolumeLabel (PChar (fDriveLetter + ':\'), PChar (Value));
        Refresh; // Ensure fVolumeName reflects reality.....
    end;
end;

procedure TFileSystem.SetFolderName (Value: String);
var
    Idx: Integer;
begin
    // Do the trivial stuff first....
    if Value = '.' then Exit;
    if Value = '' then Value := fDriveLetter + ':\';

    // Handle a request to go up one level
    if Value = '..' then begin
       if Length (fFolderName) = 3 then Exit; // Already at root
       Idx := Length (fFolderName) - 1;
       while fFolderName [Idx] <> '\' do Dec (Idx);
       Value := Copy (fFolderName, 1, Idx);
    end;

    // Handle a relative path (no leading drive letter or backslash)
    if (Value [1] <> '\') and (Value [2] <> ':') then Value := fFolderName + Value;

    // Handle an absolute path (no leading drive letter)
    if Value [1] = '\' then Value := fDriveLetter + ':' + Value;

    // Handle a path -- with drive letter
    if Value [2] = ':' then begin
        Value [1] := UpCase (Value [1]);
        if Value [1] <> fDriveLetter then Exit;
        if Value [3] <> '\' then Value := fFolderName + Copy (Value, 3, MaxInt);
    end;

    // At this point, Value should be in the form X:\YYYYYY
    // Now, we need to check that the wanted path exists
    if not DirectoryExists (Value) then Exit;

    // Finally, set the new folder name and refresh folder list
    if Value [Length (Value)] <> '\' then Value := Value + '\';
    if AnsiLowerCaseFileName (Value) <> AnsiLowerCaseFileName (fFolderName) then begin
        fFolderName := Value;
        RefreshFolderAndFileList;
    end;
end;

procedure TFileSystem.SetFileTypes (Value: TFileTypes);
begin
    if Value <> fFileTypes then begin
        fFileTypes := Value;
        RefreshFolderAndFileList;
    end;
end;

class function TFileSystem.DirectoryExists (const DirName: String): Boolean;
var
    OldDir: String;
begin
    OldDir := GetCurrentDir;
    try
        Result := SetCurrentDir (DirName);
    finally
        SetCurrentDir (OldDir);
    end;
end;

function TFileSystem.MatchingFile (Rec: TSearchRec): Boolean;
begin
    Result := True;
    // Read-only file ?
    if ((Rec.Attr and faReadOnly) <> 0) and (ftReadOnly in fFileTypes) then Exit;
    // Hidden-file ?
    if ((Rec.Attr and faHidden) <> 0) and (ftHidden in fFileTypes) then Exit;
    // System-file ?
    if ((Rec.Attr and faSysFile) <> 0) and (ftSystem in fFileTypes) then Exit;
    // Archive file ?
    if ((Rec.Attr and faArchive) <> 0) and (ftArchive in fFileTypes) then Exit;
    Result := Rec.Attr = 0;
end;

procedure TFileSystem.RefreshFolderAndFileList;
var
    Err: Integer;
    Rec: TSearchRec;
begin
    fFolders.Clear;  fFiles.Clear;  fTotalFileSize := 0;
    Err := FindFirst (fFolderName + '*.*', faAnyFile, Rec);
    try
       while Err = 0 do begin
           if (Rec.Attr and faDirectory) <> 0 then begin
               // Ignore the accursed '.' and '..' names
               if Rec.Name [1] <> '.' then fFolders.Add (Rec.Name);
           end else if (Rec.Attr and faVolumeID) = 0 then
               // Not a directory, not a volumeID - must be a file!
               if MatchingFile (Rec) then begin
                   fFiles.Add (Rec.Name);
                   fTotalFileSize := fTotalFileSize + Rec.Size;
               end;

           Err := FindNext (Rec);
       end;
    finally
        FindClose (Rec);
    end;
end;

procedure TFileSystem.TreeWalkFiles (Proc: TWalkProc);
var
    Continue: Boolean;
begin
    Screen.Cursor := crHourGlass;
    try
        Continue := True;
        if Assigned (Proc) then FileWalker (fFolderName, Proc, Continue);
    finally
        Screen.Cursor := crDefault;
    end;
end;

procedure TFileSystem.TreeWalkFolders (Proc: TWalkProc);
var
    Continue: Boolean;
begin
    Screen.Cursor := crHourGlass;
    try
        Continue := True;
        if Assigned (Proc) then FolderWalker (fFolderName, Proc, Continue);
    finally
        Screen.Cursor := crDefault;
    end;
end;

procedure TFileSystem.FileWalker (const Folder: String; Proc: TWalkProc; var Continue: Boolean);
var
    Err: Integer;
    Rec: TSearchRec;
begin
    Err := FindFirst (Folder + '*.*', faAnyFile, Rec);
    try
       while (Err = 0) and Continue do begin
           if (Rec.Attr and faDirectory) <> 0 then begin
               // Ignore the accursed '.' and '..' names
               if Rec.Name [1] <> '.' then FileWalker (Folder + Rec.Name + '\', Proc, Continue);
           end else if (Rec.Attr and faVolumeID) = 0 then
               // Not a directory, not a volumeID - must be a file!
               if MatchingFile (Rec) then begin
                   Proc (Folder + Rec.Name, Rec, Continue);
               end;

           Err := FindNext (Rec);
       end;
    finally
        FindClose (Rec);
    end;
end;

procedure TFileSystem.FolderWalker (const Folder: String; Proc: TWalkProc; var Continue: Boolean);
var
    Err: Integer;
    Rec: TSearchRec;
begin
    Err := FindFirst (Folder + '*.*', faAnyFile, Rec);
    try
       while (Err = 0) and Continue do begin
           if (Rec.Attr and faDirectory) <> 0 then begin
               // Ignore the accursed '.' and '..' names
               if Rec.Name [1] <> '.' then FileWalker (Folder + Rec.Name + '\', Proc, Continue);
               Proc (Folder + Rec.Name + '\', Rec, Continue);
           end;
           Err := FindNext (Rec);
       end;
    finally
        FindClose (Rec);
    end;
end;

//--------- End of TFileSystem component ---------------------------------

var
    FileSys: TFileSystem;

procedure TForm1.FormCreate (Sender: TObject);
var
    Idx: Integer;
begin
    FileSys := TFileSystem.Create (Self);
    with FileSys do begin
        DriveTypes := [ fsFixed, fsRemote, fsCDROM ];
        for Idx := 0 to DriveCount - 1 do DriveList.Items.Add (Drives [Idx] + ':');
        DriveList.ItemIndex := 0;
        DriveListChange (Self);
        // Set File attribute checkboxes according to current 'FileTypes'
        cbReadOnly.Checked := ftReadOnly in FileTypes;
        cbHidden.Checked   := ftHidden in FileTypes;
        cbSystem.Checked   := ftSystem in FileTypes;
        cbArchive.Checked  := ftArchive in FileTypes;
    end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
    FileSys.Free;
end;

function TForm1.FormatBigBytes (const Msg: String; Value: TLargeInteger): String;
var
    Dbl: Double;
begin
     Dbl := Value;
     Result := Format (Msg + ' %n', [Dbl]);
     Result := Copy (Result, 1, Length (Result) - 3) + ' bytes';
end;

procedure TForm1.DriveListChange(Sender: TObject);
var
    S: String;

    function StrDriveType (Typ: TDriveType): String;
    begin
        case Typ of
          fsRemovable: Result := 'Removable';
          fsFixed:     Result := 'Fixed    ';
          fsRemote:    Result := 'Remote   ';
          fsCDROM:     Result := 'CD-ROM   ';
          fsRAMDisk:   Result := 'RAM-Disk ';
          else         Result := '-unknown-';
        end;
    end;

begin
    with FileSys do begin
        // First, point TFileSystem object at the new drive
        DriveLetter := DriveList.Text [1];
        // Now display the various drive properties
        VolSize.Caption := FormatBigBytes ('Total size of this drive is:', TotalSize);
        S := VolumeName;  if S = '' then S := '[None]';
        VolName.Caption := Format ('Volume label of this drive is: %s', [S]);
        FSystem.Caption := Format ('File system of this drive is: %s', [FileSystem]);
        SerNum.Caption := Format ('Serial number of this drive is: %s', [SerialNumber]);
        DrvType.Caption := Format ('Type of this drive is: %s', [StrDriveType (DriveType)]);
        FreeSp.Caption := FormatBigBytes ('Free space on this drive is:', FreeSpace);
        UpdateFolderList ('');
    end;
end;

procedure TForm1.UpdateFolderList (const FolderName: String);
begin
    if FolderName <> '' then FileSys.FolderName := FolderName;
    CurFolder.Text := FileSys.FolderName;
    FolderList.Items.Assign (FileSys.Folders);
    FolderList.ItemIndex := 0;
    FileList.Items.Assign (FileSys.Files);
    FileList.ItemIndex := 0;
    FileCount.Caption := Format ('File count = %d', [FileList.Items.Count]);
    TotFileSize.Caption := FormatBigBytes ('Total size of files is:', FileSys.TotalFileSize);
end;

procedure TForm1.FolderListChange(Sender: TObject);
begin
    UpdateFolderList (FolderList.Text);
end;

procedure TForm1.CurFolderKeyPress(Sender: TObject; var Key: Char);
begin
    if Key = #13 then UpdateFolderList (CurFolder.Text);
end;

  //  TFileType   = ( ftReadOnly, ftHidden, ftSystem, ftArchive );
  //                     1         2          4          8

procedure TForm1.cbReadOnlyClick(Sender: TObject);
var
   ft: TFileType;
begin
    with Sender as TCheckBox do begin
        ft := TFileType (Tag);
        if Checked then FileSys.FileTypes := FileSys.FileTypes + [ft]
        else FileSys.FileTypes := FileSys.FileTypes - [ft];
        FileList.Items.Assign (FileSys.Files);
        FileList.ItemIndex := 0;
        FileCount.Caption := Format ('File count = %d', [FileList.Items.Count]);
        TotFileSize.Caption := FormatBigBytes ('Total size of files is:', FileSys.TotalFileSize);
    end;
end;

procedure TForm1.SumProc (const Name: String; const Info: TSearchRec; var Continue: Boolean);
begin
    DirSize := DirSize + Info.Size;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
    DirSize := 0;
    FileSys.TreeWalkFiles (SumProc);
    ShowMessage (FormatBigBytes ('Total size of this directory is:', DirSize));
end;

end.