Subversion Repositories autosfx

unit ZMDrv19;

(*

  ZMDrv19.pas - drive details

    Copyright (C) 2009, 2010  by Russell J. Peters, Roger Aelbrecht,

      Eric W. Engler and Chris Vleghert.

        This file is part of TZipMaster Version 1.9.

    TZipMaster is free software: you can redistribute it and/or modify

    it under the terms of the GNU Lesser General Public License as published by

    the Free Software Foundation, either version 3 of the License, or

    (at your option) any later version.

    TZipMaster is distributed in the hope that it will be useful,

    but WITHOUT ANY WARRANTY; without even the implied warranty of

    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

    GNU Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General Public License

    along with TZipMaster.  If not, see <http://www.gnu.org/licenses/>.

    contact: problems@delphizip.org (include ZipMaster in the subject).

    updates: http://www.delphizip.org

    DelphiZip maillist subscribe at http://www.freelists.org/list/delphizip

  modified 2010-03-18

---------------------------------------------------------------------------*)

interface

uses

  Classes, Windows;

type

   //1 Provides details of drive

   TZMWorkDrive = class(TObject)

   private

    fDiskName: string;

    fDiskReadOnly: Boolean;

    fDiskSerial: cardinal;

    FDriveIsFloppy: Boolean;

    fDriveLetter: Char;

    fDriveStr: string;

    fDriveType: Integer;

    fLastDrive: string;

    fVolumeFreeClusters: DWORD;

    fVolumeSecSize: Cardinal;

    fVolumeSectorsPerCluster: DWORD;

    fVolumeSize: Int64;

    fVolumeSpace: Int64;

    fVolumeTotalClusters: DWORD;

    function GetDriveIsFixed: Boolean;

    procedure SetDrive(const path: string);

    procedure SetDriveStr(const Value: string);

    procedure SetExSizes(fields: Integer);

   public

    constructor Create;

    procedure AfterConstruction; override;

    procedure AssignFrom(const src: TZMWorkDrive);

    procedure Clear;

    function HasMedia(UnformOk: boolean): Boolean;

    function RenameDisk(const NewName: string): Boolean;

    procedure VolumeRefresh;

    property DiskName: string read fDiskName;

    property DiskReadOnly: Boolean read fDiskReadOnly;

    property DiskSerial: cardinal read fDiskSerial;

    property DriveIsFixed: Boolean read GetDriveIsFixed;

    property DriveIsFloppy: Boolean read FDriveIsFloppy;

    property DriveLetter: Char read fDriveLetter;

    property DriveStr: string read fDriveStr write SetDriveStr;

    property DriveType: Integer read fDriveType;

    property VolumeFreeClusters: DWORD read fVolumeFreeClusters;

    property VolumeSecSize: Cardinal read fVolumeSecSize;

    property VolumeSectorsPerCluster: DWORD read fVolumeSectorsPerCluster;

    property VolumeSize: Int64 read fVolumeSize;

    property VolumeSpace: Int64 read fVolumeSpace;

    property VolumeTotalClusters: DWORD read fVolumeTotalClusters;

   end;

implementation

uses

  SysUtils, ZMXcpt19, ZMMsg19;

Const

  MAX_REMOVABLE = 10 * 1024 * 1024;

constructor TZMWorkDrive.Create;

begin

  inherited;

end;

procedure TZMWorkDrive.AfterConstruction;

begin

  inherited;

  Clear;

end;

procedure TZMWorkDrive.AssignFrom(const src: TZMWorkDrive);

begin

  if (self <> src) then

  begin

    fDiskName := src.DiskName;

    fDiskReadOnly := src.DiskReadOnly;

    fDiskSerial := src.DiskSerial;

    fDriveIsFloppy := src.DriveIsFloppy;

    fDriveLetter := src.DriveLetter;

    fDriveStr := src.DriveStr;

    fDriveType := src.DriveType;

    fVolumeFreeClusters := src.VolumeFreeClusters;

    fVolumeSecSize := src.VolumeSecSize;

    fVolumeSectorsPerCluster := src.VolumeSectorsPerCluster;

    fVolumeSize := src.VolumeSize;

    fVolumeSpace := src.VolumeSpace;

    fVolumeTotalClusters := src.VolumeTotalClusters;

  end;

end;

procedure TZMWorkDrive.Clear;

begin

  fDiskName := '';

  fLastDrive := '';

  fDiskReadOnly := false;

  fDiskSerial := 0;

  fDriveIsFloppy := False;

  fDriveLetter := #0;

  fDriveStr := '';

  fDriveType := 0;

  fVolumeSecSize := 512;

  fVolumeSectorsPerCluster := 4;

  fVolumeSize := 0;

  fVolumeSpace := 0;    

  fVolumeTotalClusters := 0;

end;

function TZMWorkDrive.GetDriveIsFixed: Boolean;

begin

  Result := not DriveIsFloppy;

end;

function TZMWorkDrive.HasMedia(UnformOk: boolean): Boolean;

//const

//  _FILE_READ_ONLY_VOLUME = $00080000;

var

  Bits: set of 0..25;

  err: cardinal;

  NamLen: Cardinal;

  Num: Integer;

  OldErrMode: DWord;

  SysFlags: DWord;

  SysLen: DWord;

  VolNameAry: array[0..255] of Char;

begin

  NamLen := 255;

  SysLen := 255;

  fVolumeSize := 0;

  fVolumeSpace := 0;

  fDiskName := '';

  fDiskSerial := 0;

  VolNameAry[0] := #0;

  Result := False;

  if DriveLetter <> #0 then                // Only for local drives

  begin

    if (DriveLetter < 'A') or (DriveLetter > 'Z') then

      raise EZipMaster.CreateResStr( DS_NotaDrive, DriveStr);

    Integer(Bits) := GetLogicalDrives();

    Num := Ord(DriveLetter) - Ord('A');

    if not (Num in Bits) then

      raise EZipMaster.CreateResStr( DS_DriveNoMount, DriveStr);

  end;

  OldErrMode := SetErrorMode(SEM_FAILCRITICALERRORS); // Turn off critical errors:

  // Since v1.52c no exception will be raised here; moved to List() itself.

  // 1.72 only get Volume label for removable drives

  if (not GetVolumeInformation(Pchar(DriveStr), VolNameAry,

    NamLen, @fDiskSerial, SysLen, SysFlags, Nil, 0)) then

  begin

    // W'll get this if there is a disk but it is not or wrong formatted

    // so this disk can only be used when we also want formatting.

    err := GetLastError();

    if (err = 31) and (UnformOk) then

      Result := True;

  end//;

  else

  begin

    fDiskName := VolNameAry;

    fDiskReadOnly := false;

    { get free disk space and size. }

    SetExSizes(7);      // RCV150199

  end;

  SetErrorMode(OldErrMode);   // Restore critical errors:

  // -1 is not very likely to happen since GetVolumeInformation catches errors.

  // But on W95(+OSR1) and a UNC filename w'll get also -1, this would prevent

  // opening the file. !!!Potential error while using spanning with a UNC filename!!!

  if (DriveLetter = #0) or ((DriveLetter <> #0) and

    (VolumeSize <> -1)) then

    Result := True;

end;

function TZMWorkDrive.RenameDisk(const NewName: string): Boolean;

begin

  Result := false;

  if DriveIsFloppy and HasMedia(false) and not DiskReadOnly and

    SetVolumeLabel(PChar(DriveStr), PChar(NewName)) then

  begin

    HasMedia(false);  // get new name

    Result := True;

  end;

end;

procedure TZMWorkDrive.SetDrive(const path: string);

var

  s: string;

begin

  s := Uppercase(ExtractFileDrive(ExpandUNCFileName(path)) + '\');

  if s <> fLastDrive then

  begin

    Clear;

    if (length(s) = 3) and (s[2] = ':') then

    begin

      // a local drive

      fDriveLetter := s[1];

      fDriveType := GetDriveType(Pchar(s));

      if DriveType = DRIVE_REMOVABLE then

      begin

        if (DriveLetter = 'A') or (DriveLetter = 'B') then

          fDriveIsFloppy := True;

      end;

    end

    else

      Clear;

    fLastDrive := s;

    fDriveStr := s;

  end;

end;

procedure TZMWorkDrive.SetDriveStr(const Value: string);

begin

  if Value <> fDriveStr then

    SetDrive(Value);

end;

procedure TZMWorkDrive.SetExSizes(fields: Integer);

var

  BytesPSector: DWORD;

  LDiskFree: Int64;

  LSizeOfDisk: Int64;

  SSize: cardinal;

begin

  LDiskFree := -1;

  LSizeOfDisk := -1;

  SSize := 0;

  if GetDiskFreeSpace(Pchar(DriveStr), fVolumeSectorsPerCluster, BytesPSector,

    fVolumeFreeClusters, fVolumeTotalClusters) then

  begin

    SSize := BytesPSector;

  end;

  if not GetDiskFreeSpaceEx(Pchar(DriveStr), LDiskFree, LSizeOfDisk, Nil) then

  begin

    LDiskFree := -1;

    LSizeOfDisk := -1;

    if SSize <> 0 then

    begin

      LDiskFree := Int64(BytesPSector) * VolumeSectorsPerCluster *

        VolumeFreeClusters;

      LSizeOfDisk := Int64(BytesPSector) * VolumeSectorsPerCluster *

        VolumeTotalClusters;

    end;

  end;

  if (fields and 1) <> 0 then

    fVolumeSpace := LDiskFree;

  if (fields and 2) <> 0 then

    fVolumeSize := LSizeOfDisk;

  if (fields and 4) <> 0 then

    fVolumeSecSize := SSize;

end;

procedure TZMWorkDrive.VolumeRefresh;

begin

  SetExSizes(7);

end;

end.