DriveTools - nützliche Laufwerks Routinen

[Luckie]

Für ein Projekt brauchte ich ein paar Routinen bezüglich Laufwerke. Rausgekommen ist die Unit DriveTools.

Routinen:
GetLogicalDrives - Listet alle logischen Laufwerke auf

Delphi-Quellcode:

procedure GetLogicalDrives(var Drives: TStringArray; ReadyOnly: Boolean = True;
  WithLabels: Boolean = True);

Drives ist ein dynamisches String-Array, muss bereit gestellt werden
ReadyOnly, es werden nur Laufwerke berücksichtig, die bereit sind
WithLables, es werden zusätzlich die Laufwerksbezeichnungen mit angegeben

FindAllFiles - Sucht Dateien

Delphi-Quellcode:

procedure FindAllFiles(RootFolder: string; Mask: string; Recurse: Boolean =
  True);

RootFolder, Ordner der dursucht werden soll
Mask, Dateimaske der zu findenden Dateien
Recurse, rekursive Suche durch Unterverzeichnisse

Wichtig: zu FindAllFiles gehört:
InitFindAllFiles - initialisiert die globalen Variablen FoundFiles, cntFoundFiles
diese Prozedur muss immer vor FindAllFiles aufgerufen werden. FindAllFiles arbeitet mit den globalen Variablen FoundFiles, einem dynamischen String-Array und cntFoundFiles welches die gefundenen Datein zählt und für die Größe des dynamischen String-Arrays verantwortlich ist.

GetVolumeLabel - ermittelt die Datenträgerbezeichnung

Delphi-Quellcode:

function GetVolumeLabel(const Drive: string): string;

Drive ist das Laufwerk, dessen Datenträgerbezeichnug ermittelt werden soll.

Delphi-Quellcode:

{************************************************************}
{                                                            }
{                           DriveTools                       }
{                          Version: 2.0                      }
{                                                            }
{               Copyright (c) 2004 Michael Puff              }
{                     [url]www.luckie-online.de[/url]                   }
{                                                            }
{************************************************************}

{*************************************************************

  History:
    - 2004-12-18 - 1.0
      - LoadLogicalDrives
      - FindAllFiles
      - GetVolumeLabel
    - 2004-12-18 - 2.0
      - Rewrote FindAllFiles (no SysUtils, no Classes)
        and added InitFindAllFiles
      - Rewrote GetLogicalDrives (no SysUtils, no Classes)

*************************************************************}

unit DriveTools;

interface

uses Windows;

type
  TStringArray = array of string;

var
  FoundFiles   : TStringArray;
  cntFoundFiles: Integer = 0;

procedure GetLogicalDrives(var Drives: TStringArray; ReadyOnly: Boolean = True;
  WithLabels: Boolean = True);
procedure InitFindAllFiles;
procedure FindAllFiles(RootFolder: string; Mask: string; Recurse: Boolean =
  True);
function GetVolumeLabel(const Drive: string): string;

implementation

////////////////////////////////////////////////////////////////////////////////
//
//  GetVolumeLabel
//
function GetVolumeLabel(const Drive: string): string;
var
  RootDrive    : string;
  Buffer       : array[0..MAX_PATH + 1] of Char;
  FileSysFlags : DWORD;
  MaxCompLength: DWORD;
begin
  result := '';
  FillChar(Buffer, sizeof(Buffer), #0);
  if length(Drive) = 1 then
    RootDrive := Drive + ':\'
  else
    RootDrive := Drive;
  if GetVolumeInformation(PChar(RootDrive), Buffer, sizeof(Buffer), nil,
    MaxCompLength, FileSysFlags, nil, 0) then
  begin
    result := string(Buffer);
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//  GetLogicalDrives
//
procedure GetLogicalDrives(var Drives: TStringArray; ReadyOnly: Boolean = True;
  WithLabels: Boolean = True);

  function DriveIsReady(const Drive: string): Boolean;
  var
    wfd        : TWin32FindData;
    hFindData  : THandle;
  begin
    SetErrorMode(SEM_FAILCRITICALERRORS);
    hFindData := FindFirstFile(Pointer(Drive + '*.*'), wfd);
    if hFindData <> INVALID_HANDLE_VALUE then
    begin
      Result := True;
    end
    else
    begin
      Result := False;
    end;
    FindClose(hFindData);
    SetErrorMode(0);
  end;

var
  FoundDrives  : PChar;
  CurrentDrive : PChar;
  len          : DWord;
  cntDrives    : Integer;
begin
  cntDrives := 0;
  SetLength(Drives, 26);
  GetMem(FoundDrives, 255);
  len := GetLogicalDriveStrings(255, FoundDrives);
  if len > 0 then
  begin
    try
      CurrentDrive := FoundDrives;
      while CurrentDrive[0] <> #0 do
      begin
        if ReadyOnly then
        begin
          if DriveIsReady(string(CurrentDrive)) then
          begin
            if WithLabels then
              Drives[cntDrives] := CurrentDrive + ' [' +
                GetVolumeLabel(CurrentDrive) + ']'
            else
              Drives[cntDrives] := CurrentDrive;
            Inc(cntDrives);
          end;
        end
        else
        begin
          if WithLabels then
            Drives[cntDrives] := CurrentDrive + ' [' +
              GetVolumeLabel(CurrentDrive) + ']'
          else
            Drives[cntDrives] := CurrentDrive;
          Inc(cntDrives);
        end;
        CurrentDrive := PChar(@CurrentDrive[lstrlen(CurrentDrive) + 1]);
      end;
    finally
      FreeMem(FoundDrives, len);
    end;
    SetLength(Drives, cntDrives);
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//  InitFindAllFiles
//    Resets global variables FoundFiles and cntFoundFiles
//    Must always be called before FindAllFiles!!!
procedure InitFindAllFiles;
begin
  SetLength(FoundFiles, 0);
  cntFoundFiles := 0;
end;

////////////////////////////////////////////////////////////////////////////////
//
//  FindAllFiles
//
procedure FindAllFiles(RootFolder: string; Mask: string; Recurse: Boolean =
  True);
var
  hFindFile    : THandle;
  wfd          : TWin32FindData;
  Filename     : string;
begin
  if RootFolder[length(RootFolder)] <> '\' then
    RootFolder := RootFolder + '\';
  ZeroMemory(@wfd, sizeof(wfd));
  wfd.dwFileAttributes := FILE_ATTRIBUTE_NORMAL;
  if Recurse then
  begin
    hFindFile := FindFirstFile(pointer(RootFolder + '*.*'), wfd);
    if hFindFile <> 0 then
    try
      repeat
        if wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY =
          FILE_ATTRIBUTE_DIRECTORY then
          if (string(wfd.cFileName) <> '.') and (string(wfd.cFileName) <> '..')
            then
          begin
            FindAllFiles(RootFolder + wfd.cFileName, Mask, Recurse);
          end;
      until FindNextFile(hFindFile, wfd) = False;
    finally
      Windows.FindClose(hFindFile);
    end;
  end;
  hFindFile := FindFirstFile(pointer(RootFolder + Mask), wfd);
  if hFindFile <> INVALID_HANDLE_VALUE then
  try
    repeat
      if wfd.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <>
        FILE_ATTRIBUTE_DIRECTORY then
      begin
        Filename := RootFolder + string(wfd.cFileName);
        if length(FoundFiles) = cntFoundFiles then
          SetLength(FoundFiles, length(FoundFiles) + 100);
        FoundFiles[cntFoundFiles] := Filename;
        Inc(cntFoundFiles);
      end;
    until FindNextFile(hFindFile, wfd) = False;
  finally
    Windows.FindClose(hFindFile);
    setlength(FoundFiles, cntFoundFiles);
  end;
end;

end.

Eiune aktuelle Version immer unter: http://www.michael-puff.de/Developer...DriveTools.pas