FileUtils для Delphi

{ ToDo (нужно ещё сделать): }
{  - Реализовать маски - а вот это совсем не так просто :) }
// Модуль содержит множество полезных подпрограмм для работы с файловой системой
// и реестром
Unit Cmd;

interface

  // Скопировать файл
  procedure Copy( SrcFile, DstFile : String );
  // Скопировать с перезаписью
  procedure CopyOverwrite( SrcFile, DstFile : String );
  // Переименовать файл
  procedure Ren( OldName, NewName : String );
  // Удалить файл
  procedure Del( FileName : String );
  // Удалить каталог и всё вложенное
  procedure DelTree( DirName : String );
  // Создать каталог если он не существует
  procedure CreateDirSafe( DirName : string );
  // Удалить файл если он существует
  procedure DeleteIfExists_File( FileName:String );
  // Удалить каталог если он существует
  procedure DeleteIfExists_Dir( DirName:String );
  // Создание ярлыка на рабочем столе
  procedure CreateLink(
    FileOrDirName : String; // Имя файла на который будет указывать ярлык
    LinkDir  : String; // Имя каталога, где создать ярлык
    LinkName : String; // Имя ярлыка
    Arguments : String = '' // Аргументы запуска программы
   );
  // XCopyFile - надёжное копирование файла (обновление)
  procedure XCopyFile( SrcFileName,DstFileName:String );
  procedure XCopyDir( SourceDir, DestinationDir : String );
  procedure XCopyFileSafe( SrcFile,DestinationDir:String );
  // - Работа с реестром --
  function GetRegValue( KeyFullPath, KeyName: string ):string;
  procedure SetRegValue( KeyFullPath, KeyName, NewValue: string );

implementation

uses Windows,SysUtils,ShlObj,ActiveX,ComObj,XLog,
  Registry {работа с реестром};

const
  Error = '[Ошибка] ';

var Command : String;

procedure Copy( SrcFile, DstFile : String );
begin
  Command := Format('Copy(''%s'' -> ''%s'') ', [SrcFile, DstFile] );
  if not FileExists(SrcFile) then begin
    Log( Error + Command + ' файл "' + SrcFile + '" не найден!');
    exit;
  end;
  if FileExists(DstFile) then begin
    Log( Error + Command + ' файл "' + DstFile + '" уже существует!');
    exit;
  end;
  if( CopyFile( PAnsiChar(SrcFile), PAnsiChar(DstFile), True ) ) then
    Log( Command )
  else
    Log( Error + Command );
end;

procedure CopyOverwrite( SrcFile, DstFile : String );
begin
  Command := Format('CopyOverwrite(''%s'' -> ''%s'') ', [SrcFile, DstFile] );
  if not FileExists(SrcFile) then begin
    Log( Error + Command + ' файл "' + SrcFile + '" не найден!');
    exit;
  end;
  if( CopyFile( PAnsiChar(SrcFile), PAnsiChar(DstFile), False ) ) then
    Log( Command )
  else
    Log( Error + Command );
end;

procedure Ren( OldName, NewName : String );
var
  f:file;
begin
  Command := Format('Ren(''%s'' -> ''%s'') ', [OldName, NewName] );
  if not FileExists(OldName) then begin
    Log( Error + Command + ' файл "' + OldName + '" не найден!');
    exit;
  end;
  if FileExists(NewName) then begin
    Log( Error + Command + ' файл "' + NewName + '" уже существует!');
    exit;
  end;
  try
    AssignFile(f, OldName);
    Rename(f, NewName);
    Log( Command );
  except
    Log( Error + Command );
  end;
end;

procedure Del( FileName : String );
begin
  Command := Format('Del(''%s'') ', [FileName] );
  if not FileExists(FileName) then begin
    Log( Error + Command + ' файл "' + FileName + '" не найден!');
    exit;
  end;
  if DeleteFile( FileName ) then
    Log( Command )
  else
    Log( Error + Command );
end;

procedure DelTree( DirName:String );
var sr : TSearchRec;
begin
  Log('Удаляю каталог "'+DirName+'"');
  DirName := IncludeTrailingPathDelimiter(DirName);
  if FindFirst(DirName+'*.*', faAnyFile, sr) = 0 then begin
    repeat
      if ((sr.Attr and faDirectory) <> 0) then begin // Каталог
        if ((sr.Name<>'..') and (sr.Name<>'.')) then
          DelTree(DirName+sr.Name);
      end else begin // Файл
        Log('Удаляю файл "'+DirName+sr.Name+'"');
        DeleteFile( DirName+sr.Name );
      end;
    until FindNext(sr) <> 0;
    FindClose(sr);
  end;
  RemoveDir(DirName);
end;

procedure CreateDirSafe( DirName : string );
begin
  if not DirectoryExists(DirName) then begin
    MkDir( DirName );
  end;
  assert( DirectoryExists(DirName) );
end;

procedure DeleteIfExists_File( FileName:String );
begin
  if not FileExists(FileName) then begin
    Log('DeleteIfExists: "'+FileName+'" - файла нету!');
    exit;
  end;
  Log('DeleteIfExists: "'+FileName+'" - удаляем!');
  try
    FileSetAttr(FileName, 0); // Удаляем все аттрибуты
    DeleteFile(FileName);
  except
    Log('Ошибка: не могу удалить файл: "'+FileName+'"', true);
  end;
end;

procedure DeleteIfExists_Dir( DirName:String );
begin
  if not DirectoryExists(DirName) then begin
    Log('DeleteIfExists: "'+DirName+'" - каталога нету!');
    exit;
  end;
  Log('DeleteIfExists: "'+DirName+'" - удаляем!');
  try
    DelTree(DirName);
  except
    on E:Exception do Log('Ошибка: не могу удалить каталог: "'+DirName+'" - '+E.Message, true);
  end;
end;

// Перевод из стандартной строки Delphi в Unicode-строку для WinAPI
function Str2Wide( lpStr : String ):PWideChar;
var dwStrlen : Cardinal;
begin
  dwStrLen := lstrlen(PChar(lpStr));
  GetMem(Result,(dwStrLen+1)*2);
  StringToWideChar(lpStr,Result,dwStrLen+1);
end;

// Создание ярлыка на рабочем столе
procedure CreateLink(
  FileOrDirName : String; // Имя файла на который будет указывать ярлык
  LinkDir  : String; // Имя каталога, где создать ярлык
  LinkName : String; // Имя ярлыка
  Arguments : String = '' // Аргументы запуска программы
 );
var
  MyObject: IUnknown;
  MyIcon: IShellLink;
  MyPFile: IPersistFile;
  LinkFileName: String;
  TempLinkFileName: String;
begin
  MyObject := CreateComObject(CLSID_ShellLink);
  MyIcon := MyObject as IShellLink;
  MyPFile := MyObject as IPersistFile;
  with MyIcon do begin
    SetPath( PChar(FileOrDirName) ); // Путь к запускаемому файлу
    SetArguments( PChar(Arguments) ); // Аргументы запуска программы
    SetWorkingDirectory( PChar(ExtractFilePath(FileOrDirName)) ); // Рабочий каталог
  end;
  LinkFileName := LinkDir + '\' + LinkName + '.lnk';
  // Даже если ярлык есть - лучше его пересоздать - вдруг он ссылается не туда
  if FileExists(LinkFileName) then begin
//    Log('Ярлык "'+LinkFileName+'" уже есть! Пропускаю создание!');
//    exit;
    DeleteFile( LinkFileName );
  end;
  // Следующая строка почему-то не работает под WindowsXP English + MUI (русификация)
  // Такое ощущение, что иконка создаётся в неправильной кодировке.
  //  MyPFile.Save( Str2Wide(LinkFileName), False); !!!
  // В результате пользуюсь пока таким "извратом" ("грязный хак"):
  // 1. Создаём временную иконку
  TempLinkFileName := LinkDir + '\!TempLink!.lnk';
  MyPFile.Save( Str2Wide(TempLinkFileName), False);
  // 2. Переименовываем её правильно
  RenameFile( TempLinkFileName, LinkFileName  );
  if FileExists(TempLinkFileName) then
    DeleteFile(TempLinkFileName);
  Log('Создан ярлык "'+LinkFileName+'"');
end;

function GetFileTimeStamp( FileName: string ): TDateTime;
var
  FileTime, LocalFileTime : TFileTime;
  SystemTime              : TSystemTime;
  hFile                   : THandle;
begin
  hFile := FileOpen(FileName, fmShareDenyNone);
  try
    GetFileTime(hFile, nil, nil, @FileTime); // - дата изменения
    FileTimeToLocalFileTime(FileTime, LocalFileTime);
    if FileTimeToSystemTime(LocalFileTime, SystemTime) then
      Result := SystemTimeToDateTime(SystemTime);
  finally
    FileClose(hFile);
  end;
end;

// Копирование/обновление файла
// параметры - имя файла откуда копируем, имя файла куда копируем
procedure XCopyFile( SrcFileName,DstFileName:String );
var Op : String;
begin
  assert( FileExists(SrcFileName), 'Файл: "'+SrcFileName+'" отсутствует!' );
  if FileExists(DstFileName) then begin
    if GetFileTimeStamp(SrcFileName) <= GetFileTimeStamp(DstFileName) then
      exit;
    Op := 'Заменяю файл: ';
  end else begin
    Op := 'Копирую файл: ';
  end;
  Log( Op+' "'+SrcFileName+'" => "'+DstFileName+'"' );

  CopyFile( PAnsiChar(SrcFileName), PAnsiChar(DstFileName), false );
  FileSetAttr(DstFileName,FileGetAttr(SrcFileName));

  assert( FileExists(DstFileName) );
end;

procedure XCopyFileToDir( SrcFileName,DstDir:String );
var DstFileName : String;
begin
  if not DirectoryExists(DstDir) then begin
    Log('Ошибка: Каталог: "'+DstDir+'" отсутствует!',true);
    exit;
  end;
  DstFileName := IncludeTrailingPathDelimiter(DstDir) + ExtractFileName(SrcFileName);
  XCopyFile(SrcFileName, DstFileName);
end;

procedure XCopyDir( SourceDir, DestinationDir : String );
var
  Search : TSearchRec;
  Rec    : word;
begin
  assert( DirectoryExists(SourceDir), 'Каталог: "'+SourceDir+'" отсутствует!' );
  assert( DirectoryExists(DestinationDir), 'Каталог: "'+DestinationDir+'" отсутствует!' );

  SourceDir := IncludeTrailingPathDelimiter(SourceDir);
  DestinationDir := IncludeTrailingPathDelimiter(DestinationDir);
  // Поиск
  Rec := FindFirst(SourceDir + '*.*', faAnyFile, Search);
  while Rec = 0 do begin
    if Search.Name[1] <> '.' then begin
      if (Search.Attr and faDirectory) = faDirectory then begin  // Создание каталога
        Windows.CreateDirectory(PChar(DestinationDir + Search.Name), nil);
        FileSetAttr(DestinationDir + Search.Name, FileGetAttr(SourceDir + Search.Name));
        assert( DirectoryExists(DestinationDir + Search.Name) );
        XCopyDir(SourceDir + Search.Name, DestinationDir + Search.Name);
      end else begin // Создание файла
        XCopyFile( SourceDir + Search.Name, DestinationDir + Search.Name );
      end;
    end;
    Rec := FindNext(Search);
  end;
  FindClose(Search);
end;

procedure XCopyFileSafe( SrcFile,DestinationDir:String );
begin
  if not FileExists(SrcFile) then begin
    Log('Файл: "'+SrcFile+'" отсутствует!');
    exit;
  end;
  XCopyFileToDir( SrcFile,DestinationDir );
end;

// - Работа с реестром -
// используются стандартные модули Registry, Windows

function GetRegistryValue( RootKey:HKEY; KeyPath,KeyName:string ):string;
var
  Registry: TRegistry;
begin
  Registry := TRegistry.Create(KEY_READ);
  try
    Registry.RootKey := RootKey;
    // False - мы не хотим создавать путь в реестре, если он отсутствует
    Registry.OpenKey(KeyPath, False);
    Result := Registry.ReadString(KeyName);
  finally
    Registry.Free;
  end;
end;

procedure SetRegistryValue( RootKey:HKEY; KeyPath,KeyName,NewValue:string );
var
  Registry: TRegistry;
begin
  Registry := TRegistry.Create;
  try
    Registry.RootKey := RootKey;
    if Registry.OpenKey(KeyPath, True) then begin
      Registry.WriteString(KeyName,NewValue);
      Registry.CloseKey;
    end;
  finally
    Registry.Free;
  end;
end;

function GetRootKey( KeyFullPath: string ):HKEY;
var RootName : string;
begin
  // Получаем текстовое имя корня
  RootName := System.Copy(KeyFullPath,1,Pos('\',KeyFullPath)-1);
  Result := 0;
  if RootName = 'HKEY_CLASSES_ROOT' then Result := HKEY_CLASSES_ROOT;
  if RootName = 'HKEY_CURRENT_USER' then Result := HKEY_CURRENT_USER;
  if RootName = 'HKEY_LOCAL_MACHINE' then Result := HKEY_LOCAL_MACHINE;
  if RootName = 'HKEY_USERS' then Result := HKEY_USERS;
  if RootName = 'HKEY_PERFORMANCE_DATA' then Result := HKEY_PERFORMANCE_DATA;
  if RootName = 'HKEY_CURRENT_CONFIG' then Result := HKEY_CURRENT_CONFIG;
  if RootName = 'HKEY_DYN_DATA' then Result := HKEY_DYN_DATA;
  assert( Result <> 0, 'Недопустимый корневой раздел реестра: "'+KeyFullPath+'". '+
    'Должен быть: HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, '+
    'HKEY_USERS, HKEY_PERFORMANCE_DATA, HKEY_CURRENT_CONFIG, HKEY_DYN_DATA');
end;

function GetRegValue( KeyFullPath, KeyName: string ):string;
var
  KeyPath : string;
begin
  KeyPath := System.Copy(KeyFullPath,Pos('\',KeyFullPath),MaxLongint);
  Result := GetRegistryValue(GetRootKey(KeyFullPath),KeyPath,KeyName);
end;

procedure SetRegValue( KeyFullPath, KeyName, NewValue: string );
var
  KeyPath : string;
begin
  KeyPath := System.Copy(KeyFullPath,Pos('\',KeyFullPath),MaxLongint);
  SetRegistryValue(GetRootKey(KeyFullPath),KeyPath,KeyName,NewValue);
end;

end.

Пример использования:

// Компиляция: 
//  dcc32.exe cmd.dpr 
{$APPTYPE CONSOLE}
Uses cmd;
begin
  CopyOverwrite('cmd.pas','cmd.bak');
  Ren('cmd.bak','cmd.old');
  Del('*.~*');
end.

И ещё один пример:

{$APPTYPE CONSOLE}
Uses SysUtils;

var Mask : string;

procedure ClearTree( Path:String );
var sr : TSearchRec;
begin
  Path := IncludeTrailingPathDelimiter(Path);
  // Обход всех подкаталогов
  if FindFirst(Path+'*.*', faDirectory, sr) = 0 then begin
    repeat
      if ((sr.Name<>'..') and (sr.Name<>'.')) then begin
        if ((sr.Attr and faDirectory) <> 0) then
          ClearTree(Path+sr.Name+'\');
      end;
    until FindNext(sr) <> 0;
    FindClose(sr);
  end;
  // Удаление файлов по маске
  if FindFirst(Path+Mask, faAnyFile, sr) = 0 then begin
    repeat
      if (sr.Attr and faDirectory)=0 then begin
        Writeln('DeleteFile "'+Path+sr.Name+'"');
        DeleteFile( Path+sr.Name );
      end;
    until FindNext(sr) <> 0;
    FindClose(sr);
  end;
end;

begin
  Writeln('Утилита для удаления файлов по маске из дерева каталогов');
  Writeln('Использование: DelMask <маска> <начальный_каталог>');
  Writeln('Пример использования: DelMask *.bak D:\temp');
  Writeln('Для удобства использования скопируйте DelMask.exe в каталог C:\Windows');
  if ParamCount = 2 then begin
    Mask := ParamStr(1);
    Writeln('Маска: "'+Mask+'" Обработка каталога: "'+ParamStr(2)+'"');
    ClearTree(ParamStr(2));
  end;
end.