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

Pascal/Delphi Source File | 1999-09-23 | 7.1 KB | 234 lines

unit UFileSys;

interface

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

type
  TForm1 = class(TForm)
    DriveList: TRzTabbedListBox;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  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;

    TFileSystem = class (TComponent)
    private
        fDriveLetter: Char;
        fSerialNumber: DWord;
        fDriveType: TDriveType;
        fDriveTypes: TDriveTypes;
        fFileSystem, fDrives, fVolumeName: String;
        fTotalSize, fAvailableSpace, fFreeSpace: TLargeInteger;
        procedure InitDrivesList;
        function GetDriveCount: Integer;
        function GetIsReady: Boolean;
        procedure SetDriveLetter (Value: Char);
        function GetDriveChar (Index: Integer): Char;
        function GetUsedSpace: TLargeInteger;
        function GetSerialNumber: String;
        procedure SetVolumeName (Value: String);
        procedure SetDriveTypes (Value: TDriveTypes);
    public
        constructor Create (AOwner: TComponent); override;
        destructor Destroy; override;
        procedure Refresh;
        property Drives [Index: Integer]: Char read GetDriveChar;
    published
        // 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);
    SetDriveTypes ([fsFixed]);
end;

destructor TFileSystem.Destroy;
begin
    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;
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;

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

procedure TForm1.FormCreate (Sender: TObject);
var
    S: String;
    Idx: Integer;
    TotBytes: Double;
    FileSys: TFileSystem;

    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
    FileSys := TFileSystem.Create (Self);
    with FileSys do try
        DriveTypes := [ fsRemovable, fsFixed, fsRemote, fsCDROM ];
        for Idx := 0 to DriveCount - 1 do begin
            try
                DriveLetter := Drives [Idx];
                S := DriveLetter + ':' + #9 + VolumeName + #9 + FileSystem + #9 + SerialNumber + #9;
                TotBytes := TotalSize;
                S := S + Format ('%n', [TotBytes]);
                SetLength (S, Length (S) - 3);
                S := S + #9 + StrDriveType (DriveType);
            except
                on EFileSystem do S := Drives [Idx] + ':' + #9 + '---<not ready>---';
            end;
            DriveList.Items.Add (S);
        end;
    finally
        FileSys.Free;
    end;
end;

end.