home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kompon / d2345 / MSYSINFO.ZIP / Source / MSI_Disk.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-06-05  |  6.6 KB  |  199 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       MiTeC System Information Component              }
  5. {               Disk Detection Part                     }
  6. {           version 5.5 for Delphi 3,4,5                }
  7. {                                                       }
  8. {       Copyright ⌐ 1997,2001 Michal Mutl               }
  9. {                                                       }
  10. {*******************************************************}
  11.  
  12. {$INCLUDE MITEC_DEF.INC}
  13.  
  14. unit MSI_Disk;
  15.  
  16. interface
  17.  
  18. uses
  19.   SysUtils, Windows, Classes, MiTeC_Routines;
  20.  
  21. type
  22.   TDisk = class(TPersistent)
  23.   private
  24.     FDisk: TDiskSign;
  25.     FMediaPresent: Boolean;
  26.     FDriveType: TMediaType;
  27.     FSectorsPerCluster: DWORD;
  28.     FBytesPerSector: DWORD;
  29.     FFreeClusters: DWORD;
  30.     FTotalClusters: DWORD;
  31.     FFileFlags: TFileFlags;
  32.     FVolumeLabel: string;
  33.     FSerialNumber: string;
  34.     FFileSystem: string;
  35.     FFreeSpace: int64;
  36.     FCapacity: int64;
  37.     FAvailDisks: string;
  38.     FSerial: dword;
  39.     function GetMediaPresent: Boolean;
  40.   protected
  41.     procedure SetDisk(const Value: TDiskSign);
  42.   public
  43.     procedure GetInfo;
  44.     procedure Report_FileFlags(var AFileFlags :TStringList);
  45.     procedure Report(var sl :TStringList);
  46.     function GetCD :byte;
  47.     property Serial :dword read FSerial write FSerial stored false;
  48.   published
  49.     property Drive :TDiskSign read FDisk write SetDisk stored false;
  50.     property AvailableDisks :string read FAvailDisks write FAvailDisks stored false;
  51.     property MediaPresent :Boolean read GetMediaPresent write FMediaPresent stored false;
  52.     property MediaType :TMediaType read FDriveType write FDriveType stored false;
  53.     property FileFlags :TFileFlags read FFileFlags write FFileFlags stored false;
  54.     property FileSystem :string read FFileSystem write FFileSystem stored false;
  55.     property FreeClusters :DWORD read FFreeClusters write FFreeClusters stored false;
  56.     property TotalClusters :DWORD read FTotalClusters write FTotalClusters stored false;
  57.     // FreeSpace and Capacity returns good results for Win95 OSR2, Win98, NT and 2000
  58.     // for Win95 there can be bad sizes for drives over 2GB
  59.     property FreeSpace :int64 read FFreeSpace write FFreeSpace stored false;
  60.     property Capacity :int64 read FCapacity write FCapacity stored false;
  61.     property SerialNumber :string read FSerialNumber write FSerialNumber stored false;
  62.     property VolumeLabel :string read FVolumeLabel write FVolumeLabel stored false;
  63.     property SectorsPerCluster :DWORD read FSectorsPerCluster write FSectorsPerCluster stored false;
  64.     property BytesPerSector :DWORD read FBytesPerSector write FBytesPerSector stored false;
  65.   end;
  66.  
  67. implementation
  68.  
  69. { TDisk }
  70.  
  71. function TDisk.GetCD: byte;
  72. var
  73.   i :integer;
  74.   root :pchar;
  75. begin
  76.   result:=0;
  77.   root:=stralloc(255);
  78.   for i:=1 to length(FAvailDisks) do begin
  79.     strpcopy(root,copy(FAvailDisks,i,1)+':\');
  80.     if getdrivetype(root)=drive_cdrom then begin
  81.       result:=i;
  82.       break;
  83.     end;
  84.   end;
  85.   strdispose(root);
  86. end;
  87.  
  88. procedure TDisk.Report_FileFlags;
  89. begin
  90.   with AFileFlags do begin
  91.     Add(Format('Case Is Preserved=%d',[integer(fsCaseIsPreserved in FileFlags)]));
  92.     Add(Format('Case Sensitive=%d',[integer(fsCaseSensitive in FileFlags)]));
  93.     Add(Format('Unicode Stored On Disk=%d',[integer(fsUnicodeStoredOnDisk in FileFlags)]));
  94.     Add(Format('Persistent Acls=%d',[integer(fsPersistentAcls in FileFlags)]));
  95.     Add(Format('File Compression=%d',[integer(fsFileCompression in FileFlags)]));
  96.     Add(Format('Volume Is Compressed=%d',[integer(fsVolumeIsCompressed in FileFlags)]));
  97.     Add(Format('Long Filenames=%d',[integer(fsLongFileNames in FileFlags)]));
  98.     Add(Format('Encrypted File System Support=%d',[integer(fsEncryptedFileSystemSupport in FileFlags)]));
  99.     Add(Format('Object IDs Support=%d',[integer(fsObjectIDsSupport in FileFlags)]));
  100.     Add(Format('Reparse Points Support=%d',[integer(fsReparsePointsSupport in FileFlags)]));
  101.     Add(Format('Sparse Files Support=%d',[integer(fsSparseFilesSupport in FileFlags)]));
  102.     Add(Format('Disk Quotas Support=%d',[integer(fsDiskQuotasSupport in FileFlags)]));
  103.   end;
  104. end;
  105.  
  106. procedure TDisk.GetInfo;
  107. var
  108.   i,n :integer;
  109.   buf :pchar;
  110. begin
  111.   try
  112.  
  113.   buf:=stralloc(255);
  114.   n:=GetLogicalDriveStrings(255,buf);
  115.   FAvailDisks:='';
  116.   for i:=0 to n do
  117.     if buf[i]<>#0 then begin
  118.       if (ord(buf[i]) in [$41..$5a]) or (ord(buf[i]) in [$61..$7a]) then
  119.         FAvailDisks:=FAvailDisks+upcase(buf[i])
  120.     end else
  121.       if buf[i+1]=#0 then
  122.         break;
  123.   strdispose(buf);
  124.  
  125.   except
  126.     on e:Exception do begin
  127.       MessageBox(0,PChar(e.message),'TDisk.GetInfo',MB_OK or MB_ICONERROR);
  128.     end;
  129.   end;
  130. end;
  131.  
  132.  
  133. function TDisk.GetMediaPresent :Boolean;
  134. begin
  135.   Result:=MiTeC_Routines.GetMediaPresent(FDisk);
  136. end;
  137.  
  138. procedure TDisk.Report(var sl: TStringList);
  139. var
  140.   i :integer;
  141. begin
  142.   with sl do begin
  143.     Add('[Disks]');
  144.     Add(Format('Available=%s',[AvailableDisks]));
  145.     for i:=1 to Length(AvailableDisks) do begin
  146.       Drive:=copy(AvailableDisks,i,1)+':';
  147.       Add(Format('[Disk%s]',[Drive]));
  148.       Add(Format('VolumeLabel=%s',[VolumeLabel]));
  149.       Add(Format('Type=%s',[GetMediaTypeStr(MediaType)]));
  150.       Add(Format('UNC=%s',[ExpandUNCFilename(Drive)]));
  151.       Add(Format('SerialNumber=%s',[SerialNumber]));
  152.       {$IFDEF D4PLUS}
  153.       Add(FormatFloat('Capacity=0,##',Capacity));
  154.       Add(FormatFloat('FreeSpace=0,##',FreeSpace));
  155.       {$ELSE}
  156.       Add(FormatFloat('Capacity=0,##',Capacity.QuadPart));
  157.       Add(FormatFloat('FreeSpace=0,##',FreeSpace.QuadPart));
  158.       {$ENDIF}
  159.       Add(FormatFloat('BytesPerSector=0',BytesPerSector));
  160.       Add(FormatFloat('SectorPerCluster=0',SectorsPerCluster));
  161.       Add(FormatFloat('FreeClusters=0,##',FreeClusters));
  162.       Add(FormatFloat('TotalClusters=0,##',TotalClusters));
  163.       Add(Format('[Disk%s_Flags]',[Drive]));
  164.       Report_FileFlags(sl);
  165.     end;
  166.   end;
  167. end;
  168.  
  169. procedure TDisk.SetDisk(const Value: TDiskSign);
  170. var
  171.   DI: TDiskInfo;
  172. begin
  173.   try
  174.  
  175.   FDisk:=Value;
  176.   DI:=GetDiskInfo(Value);
  177.   FDriveType:=DI.MediaType;
  178.   FFileFlags:=DI.FileFlags;
  179.   FCapacity:=DI.Capacity;
  180.   FFreeSpace:=DI.FreeSpace;
  181.   FBytesPerSector:=DI.BytesPerSector;
  182.   FTotalClusters:=DI.TotalClusters;
  183.   FFreeClusters:=DI.FreeClusters;
  184.   FSectorsPerCluster:=DI.SectorsPerCluster;
  185.   FVolumeLabel:=DI.VolumeLabel;
  186.   FFileSystem:=DI.FileSystem;
  187.   FSerialNumber:=DI.SerialNumber;
  188.   FSerial:=DI.Serial;
  189.  
  190.   except
  191.     on e:Exception do begin
  192.       MessageBox(0,PChar(e.message),'TDisk.SetDisk',MB_OK or MB_ICONERROR);
  193.     end;
  194.   end;
  195. end;
  196.  
  197.  
  198. end.
  199.