Блог программистов

Наверно все читали мою статью про упаковку файлов с помощью библиотеки ZLib в Delphi. В ней написано, как можно архивировать файлы почти с той же степенью сжатия, как и ZIP. Но я описал, как можно архивировать только единичные файлы. По многочисленным заявкам читателей я пишу ещё одну статью про архивирование целых папок.
Для того, что бы архивировать папку, давайте сначала научимся склеивать все файлы, находящиеся в некоторой папке. Давайте сначала разберёмся с форматом этого склеенного файла, а будут он примерно таким

Первые четыре байта будет составлять сигнатура, которая будет обозначать, что это файл нашего формата
Следующие четыре байта будут обозначать количество файлов в этом склеенном файле
Потом будет идти массив структур, который будет описывать все файлы в этом склеенном файле, каждая структура будет иметь вот такой формат

1. 2 байта — длина имени файла
2. Размер этого поля равен значению предыдущего поля — Полное имя файла, исключая путь к нашей папке, т.е. путь к файлу в нашей папке.
3. 4 байта — Размер файла
4. Размер этого поля равен значению предыдущего поля — Само содержание файла

В данной структуре максимальный размер одного файла может быть максимум 2^32 байт, т.е. 4 ГБ. Кстати, для повышения вышей образованности формат сохранения строки, который я использую, называется LS, т.е. сначала пишется длина стоки потом сама строка. Итак, приступим к кодингу. Сначала нам надо получить список всех файлов в папке. Напишем функцию, которой мы будем передавать путь к папке, а она нам будет возвращать объект TStringList в котором и будет лежать список всех файлов в папке.

function GetAllFiles (Filter, Folder: string):TFilesList;
var
  sr: TSearchRec;
  sDirList,_FilesList,_LST: TStringList;
  i,j: Integer;
begin
  j:=0;
  _FilesList:= TStringList.create;
  _FilesList.Clear;

В начале мы создаём объект результат , а потом мы ищем все файлы которые находятся в папке путь к которой был передан в качестве второго параметра. Я думаю здесь нет ничего сложного. Первые два найденных файла игнорируются потому что это папки . и .. при переходе на которых мы остаёмся в этой папке и переходим на один уровень вверх соответственно.

  if FindFirst (Folder + Filter,faAnyFile , sr) = 0 then
  repeat
    j:=j+1;
    if j<3 then Continue;
    if (sr.Attr and fadirectory)=faDirectory then Continue;
    _FilesList.Add(Folder + sr.Name);
  until FindNext(sr)  0;
  FindClose(sr);

Далее мы создаём объект, в котором будет храниться список подпапок, и вызываем для каждой подпапки саму себя. Здесь немного по-другому игнорируются первые два пункта я это сделал только лишь для разнообразия (кстати, так намного лучше, чем то что мы применяли при поиске файлов). После получения списка файлов в каждой подпапке мы копируем полученный список в список результат.

  sDirList := TStringList.Create;
  try
    GetSubDirs (Folder, sDirList);
    for i := 0 to sDirList.Count - 1 do
      if (sDirList  '.') and (sDirList  '..') then
      begin
        _LST:=GetAllFiles(Filter,IncludeTrailingPathDelimiter (Folder + sDirList));
        for j:=0 to _LST.Count-1 do
         _FilesList.Add(_LST.Strings[j]);
        _LST.free;
      end;
  finally
    sDirList.Free;
  end;
  Result:= _FilesList;
end;

В этой функции мы применяли способ вызова функции из самой себя, настоятельно не рекомендую использовать такой способ при выполнении операций требующих очень большого количества вызовов функции, так как это может вызвать переполнение стека. В Windows стек ограничен 1 МВ. Поэтому функция (если у неё один параметр) может вызвать себя только 131072 раз, вы скажете «столько раз вызвать саму себя невозможно». А если у функции 5 параметров то 1048576/(6*4) = 34952. А это уже не очень много. Вы спросите, зачем нам нужен параметр, который задаёт фильтр, я отвечу «просто так», мало ли что, может пригодиться. Ах да забыл привести процедуру получения списка подпапок. Лист с результатом можно было возвращать в качестве результата, но для разнообразия это тоже не помешает.

procedure GetSubDirs (Folder: string; sList: TStringList);
var
  sr: TSearchRec;
begin
  if FindFirst (Folder + '*.*', faDirectory, sr) = 0 then
  try
    repeat
      if (sr.Attr and faDirectory) = faDirectory then
        sList.Add (sr.Name);
    until FindNext(sr)  0;
  finally
    FindClose(sr);
  end;
end;

Едем далее… после получения списка файлов нам надо все эти файлы склеить в один. Я специально пойду, не так как говорил в начале. Будем делать так: нашей функции будет передаваться функция которая будет делать с файлом некоторое действие которое нужно вам. Заголовок функции будет такой

type
TActionFuntion = function(SourceFileName, DestFileName: string):boolean;

Результат функции будет обозначать успешность действия. Сейчас вам, конечно же, ничего не понятно, сейчас всё поймёте. Функции упаковки папки будет передаваться папка, файл результат и функция обратного вызова, которая будет вызываться для каждого файла в этой папке. В общем, вот код этой функции

function DoFolderAction;
var
  ArchiveFile,CurrFile:THandle;
  Value,i,CurrFileSize,_readed,_writed:DWORD;
  _Files:TStringList;
  path_in_archive_file:string;
  pBuff:Pointer;
begin
  Result:=false;
  if FolderPath[Length(FolderPath)]'\' then
   FolderPath:=FolderPath+'\';

  _Files:=GetAllFiles('*.*',FolderPath);

  ArchiveFile:=CreateFile(pchar(ArchivePath), GENERIC_READ+GENERIC_WRITE, FILE_SHARE_READ,0, CREATE_ALWAYS,0,0);

  Value:=ArchiveSignature;
  WriteFile(ArchiveFile,value,4,_writed,0);//write main archive signature
  Value:=_Files.Count;
  WriteFile(ArchiveFile,value,4,_writed,0);//write files count

  for i:=0 to value-1 do
   begin

Далее мы вызываем функцию обратного вызова, которой передаём файл источник и файл результат, файл-результат это всего лишь промежуточный файл, потом мы его удалим. Переменную bkpFile можно объявить как константу.

    if not ActionFunction(_Files.Strings,bkpFile) then
     begin
{если функция обратного вызова завершилась неудачно, выходим из функции, если это не нужно то можно этот код закоментарить, но тогда наша функция будет завершаться удачно даже если какой то файл не был обработан }
      CloseHandle(ArchiveFile);
      exit;
     end;
    CurrFile:=CreateFile(pchar(bkpFile),GENERIC_READ,FILE_SHARE_READ,0,OPEN_EXISTING,0,0);
    CurrFileSize:=GetFileSize(CurrFile,nil);
    path_in_archive_file:=copy(_Files.Strings,length(FolderPath),1000);// XA XA XA XA XA
    if path_in_archive_file[1] = '\' then
     Delete(path_in_archive_file,1,1);
    Write_LS(ArchiveFile,path_in_archive_file);
    WriteFile(ArchiveFile,currFileSize,4,_writed,0);
    pBuff:=VirtualAlloc(0,MainBufferSize,MEM_COMMIT+MEM_RESERVE,PAGE_READWRITE);

    repeat
     ReadFile(CurrFile,pBuff^,MainBufferSize,_readed,0);
     WriteFile(ArchiveFile,pBuff^,_readed,_writed,0);
    until _writed<MainBufferSize;

    VirtualFree(pBuff,MEM_RELEASE,0);

    CloseHandle(CurrFile);
    DeleteFile(bkpFile);
   end;

  CloseHandle(ArchiveFile);
  Result:=True;
end;

Теперь приведу функцию, которая распаковывает всё это дело. Полный код функции смотрите в исходнике.

function De_DoFolderAction (FolderPath, ArchivePath :string; DeActionFunction :TActionFuntion) :boolean;
var
………
begin
 ArchiveFile := CreateFile(pchar(ArchivePath), GENERIC_READ+GENERIC_WRITE, FILE_SHARE_READ,0,OPEN_EXISTING,0,0);
 ReadFile(ArchiveFile,value,4,_readed,0); {проверяем наш ли это формат}
 if Value ArchiveSignature then
  begin
………
  end;
 ReadFile(ArchiveFile,_Count,4,_readed,0); {получаем количество файлов}
 for i:=1 to _Count do
  begin
   path_in_archive_file := Read_LS(ArchiveFile);
   ReadFile(ArchiveFile,CurrFileSize,4,_readed,0);
………
   for j:=1 to CurrFileSize div MainBufferSize do
    begin
     ReadFile(ArchiveFile,pBuff^,MainBufferSize,_readed,0);
     WriteFile(CurrFile,pBuff^,_readed,_writed,0);
    end;
   ReadFile(ArchiveFile, pBuff^, CurrFileSize mod MainBufferSize, _readed,0);
   WriteFile(CurrFile,pBuff^,_readed,_writed,0);
………
   if FolderPath[Length(FolderPath)]'\' then Delete(FolderPath,Length(FolderPath),1);
   if path_in_archive_file[1]'\' then path_in_archive_file := '\' + path_in_archive_file;
   path_in_archive_file :=FolderPath+path_in_archive_file;
   makedir(ExtractFileDir(path_in_archive_file));
{код этой функции тоже смотрите  в исходнике}
   if not  DeActionFunction(bkpfile,path_in_archive_file) then
    begin
………
    end;
………
  end;
………
end;

Теперь для того чтобы просто склеить все файлы в папке в один файл надо сделать это:

function DODO(fl1,fl2:string):boolean;
begin
  Result:=CopyFile(pchar(fl1),pchar(fl2),false);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 DoFolderAction('F:\111','F:\arch.dat',DODO);  
 De_DoFolderAction('F:\112','F:\arch.dat',DODO);
end

Для того чтобы упаковать папку, используя функции, описанные мной в предыдущей статье, надо сделать так:

function DODO2(fl1,fl2:string):boolean;
begin
 Result:=ZLATCompressFile(fl1,fl2,2,false,true,nil,0,0) <> 0;
end;

function DODO3(fl1,fl2:string):boolean;
begin
 Result:=ZLATdecompressfile(fl1,fl2,false,true,nil,0,0);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 DoFolderAction('F:\111\','F:\arch.dat',DODO2);
 De_DoFolderAction('F:\112\','F:\arch.dat',DODO3)
end;

Конечно, можно было сначала склеить все файлы, потом сжать склеенный файл, а для распаковки сначала распаковать и потом расклеить. С тем же успехом можно шифровать целые папки, используя технологию шифровки которые я описал в своих предыдущих статье и статье. Короче кидаете файл FolderActions.pas в расшаренную для Delphi папку и пользуетесь модулем на здоровье.
Вот, пожалуй, и всё.
Модуль для упаковки папок
архив с исходниками к предыдущей статье