VPF::7z.dll+sevenzip.pas для Delphi - Форум программистов

CHERRY

Дата 30.10.2012, 20:52 (ссылка)

(нет голосов)

Загрузка ...

Прохожий

Профиль
Группа: Участник
Сообщений: 150
Регистрация: 17.6.2002
Где: Одесса

Репутация: нет
Всего: -2

Доброго времени суток!
Есть не решаемые проблемы с ProgressCallback.
Распаковка архива работает без проблем:

Код


function ProgressCallback(sender: Pointer; total: boolean; value: int64): HRESULT; stdcall;
 begin
   if total then
     Form1.ProgressBar1.Max := value else
     Form1.ProgressBar1.Position := value;
   Result := S_OK;
 end;

procedure TForm1.butExtractClick(Sender: TObject);
begin
  with CreateInArchive(CLSID_CFormatZip) do
  begin
    OpenFile('d:\temp\test.zip');
    SetProgressCallback(nil, ProgressCallback);
    ExtractTo('d:\temp\1111\');
  end;
end;

С архивацией проблемы:

Код


procedure TForm1.butCompressClick(Sender: TObject);
begin
  with CreateOutArchive(CLSID_CFormatZip) do
  begin
    AddFiles(ediSource.Text, ExtractFileName(ediSource.Text), '*.*', True);
    SetProgressCallback(nil, ProgressCallback);
    SaveToFile(ediDestFile.Text);
  end;
end;

Если закомментировать SetProgressCallback(nil, ProgressCallback);, архивация проходит нормально.
Иначе все виснет намертво.
Это глюки продукта или непонимание процесса.

Версия продукта:
(*                        7-ZIP DELPHI API                                      *)
(* Unit owner : Henri Gourvest <[email protected]>     *)
(* V1.2                                                                                  *)
Оригинал прилагается.
(********************************************************************************)

Присоединённый файл ( Кол-во скачиваний: 184 )

7_zip_Delphi_API.7z 9,43 Kb

--------------------

Трясу надежды ветвь, но где желанный плод?

CHERRY

Дата 30.10.2012, 22:30 (ссылка)

(нет голосов)

Загрузка ...

Прохожий

Профиль
Группа: Участник
Сообщений: 150
Регистрация: 17.6.2002
Где: Одесса

Репутация: нет
Всего: -2

Выяснилось, что ProgressCallback при архивации срабатывает для одного файла.
Вот рабочий пример:

Код


function ProgressCallback(sender: Pointer; total: boolean; value: int64): HRESULT; stdcall;
 begin
   if total then
     fmArxiv.ProgressBar1.Max := value else
     fmArxiv.ProgressBar1.Position := value;
   Result := S_OK;
 end;

procedure TfmArxiv.Button3Click(Sender: TObject);
begin
 DoCreateArchive('d:\temp\kot.bmp', 'd:\temp\1111111.zip')
end;

//Архивация
function TfmArxiv.DoCreateArchive(const arFilename, arSaveTo: string): Boolean;
var
  OutArchive: I7zOutArchive;
begin
  Result := False;
  // создаем ZIP-архив
  OutArchive := CreateOutArchive(CLSID_CFormatZip);
  try
    //Добавим один файл в архив
    OutArchive.AddFile(arFilename, ExtractFileName(arFilename));
     //Добавим директорий в архив
     //вызов: DoCreateArchive('d:\temp\111', 'd:\temp\1111111.zip')
    //OutArchive.AddFiles(arFilename,ExtractFileName(arFilename),'*.*',true);
    // степень сжатия максимальная
    SetCompressionLevel(OutArchive, 5);
    // метод сжатия Deflate (гарантия того, что архив может впоследствии распакован
    // любым ZIP-архиватором независимо от платформы)
    SetCompressionMethod(OutArchive, mzDeflate);

    OutArchive.SetProgressCallback(nil,ProgressCallback);

    OutArchive.SaveToFile(arSaveTo);
    Result := FileExists(arSaveTo);
  finally
    OutArchive := nil;
  end;
end;

Как то так.

--------------------

Трясу надежды ветвь, но где желанный плод?

CHERRY

Дата 1.11.2012, 16:18 (ссылка)

(нет голосов)

Загрузка ...

Прохожий

Профиль
Группа: Участник
Сообщений: 150
Регистрация: 17.6.2002
Где: Одесса

Репутация: нет
Всего: -2

Все хорошо работает только для архивов 7z
OutArchive := CreateOutArchive(CLSID_CFormatZip);
Спасибо за внимание.

Добавлено через 1 минуту и 34 секунды
Ошибочка, вот так
CreateOutArchive(CLSID_CFormat7z)

--------------------

Трясу надежды ветвь, но где желанный плод?

barbee

Дата 6.6.2013, 22:22 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 1
Регистрация: 6.6.2013

Репутация: 1
Всего: 1

Времени прошло немало, но всё же вопрос висит без ответа, а топик в гугле находится первым по запросу "sevenzip.pas setprogresscallback".
Так что напишу, как решить проблему, мало ли кто-то ещё столкнётся.

Дело явно в кривой работе с потоками где-то на стыке VCL и 7z.dll. То ли распаковка там идёт не в том потоке, где нужно, то ли ещё что. В общем, расковыривать проблему до основания я не стал, благо решение быстро нашлось.

Пример одного из вариантов решения приложен в комментариях прямо на странице проекта.

Второй, на мой взгляд, несколько проще. Достаточно одного вызова, по документации устанавливающего количество рабочих потоков в 1.

Код

SetMultiThreading(OutArchive, 1);

И всё начинает работать как надо.

Итого, код будет выглядеть так:

Код


function ProgressCallback(sender: Pointer; total: boolean; value: int64): HRESULT; stdcall;
 begin
   if total then
     fmArxiv.ProgressBar1.Max := value else
     fmArxiv.ProgressBar1.Position := value;
   Result := S_OK;
 end;

procedure TfmArxiv.Button3Click(Sender: TObject);
begin
 DoCreateArchive('d:\temp\kot.bmp', 'd:\temp\1111111.zip')
end;

//Архивация
function TfmArxiv.DoCreateArchive(const arFilename, arSaveTo: string): Boolean;
var
  OutArchive: I7zOutArchive;
begin
  Result := False;
  // создаем ZIP-архив
  OutArchive := CreateOutArchive(CLSID_CFormatZip);
  try
    //Добавим один файл в архив
    OutArchive.AddFile(arFilename, ExtractFileName(arFilename));
     //Добавим директорий в архив
     //вызов: DoCreateArchive('d:\temp\111', 'd:\temp\1111111.zip')
    //OutArchive.AddFiles(arFilename,ExtractFileName(arFilename),'*.*',true);
    // степень сжатия максимальная
    SetCompressionLevel(OutArchive, 5);
    // метод сжатия Deflate (гарантия того, что архив может впоследствии распакован
    // любым ZIP-архиватором независимо от платформы)
    SetCompressionMethod(OutArchive, mzDeflate);

    // ограничиваем количество потоков
    SetMultiThreading(OutArchive, 1);

    OutArchive.SetProgressCallback(nil,ProgressCallback);

    OutArchive.SaveToFile(arSaveTo);
    Result := FileExists(arSaveTo);
  finally
    OutArchive := nil;
  end;
end;

1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »