[El Sanchez]

во время упаковки всё замирает, кнопка Отмена НЕ активна, конечный пользователь может решить что всё зависло, а создание некоторых больших архивов может занимает до 5-7 минут! »

TROY Diamond, ясно, так и знал, что по-простому не выйдет.

Скрытый текст

Код:

[Languages]
Name: ru; MessagesFile: compiler:Languages\russian.isl

[CustomMessages]
ru.SevenZipStatusPackFiles=Упаковка файлов из %1:
ru.SevenZipProgressCaptions=Прогресс:%nСкорость:%nПрошло:%nОсталось:
ru.SevenZipProgressInfo=%1%% (%2 из %3)%n%4%n%5%n%6
ru.SevenZipPackFailed=При создании архива %1 произошла ошибка. Код ошибки: %2
ru.UnableDeleteEmptyFolder=Не удалось удалить пустую папку %1. Код ошибки: %2 (%3)

[Files]
Source: 7-zip32.dll; Flags: dontcopy
#ifndef IS_ENHANCED
; http://restools.hanzify.org/inno/callbackctrl/InnoCallbackCtrl_V1.1.zip
Source: CallbackCtrl.dll; Flags: dontcopy
#endif
; {app}\data\test01
Source: {app}\test01\*; DestDir: {app}\data\test01; Flags: ignoreversion overwritereadonly recursesubdirs createallsubdirs sortfilesbyextension
Source: dummy; DestDir: {app}\data; AfterInstall: Pack(ExpandConstant('{app}\data\test01')); Flags: deleteafterinstall
; {app}\data\test02
Source: {app}\test02\*; DestDir: {app}\data\test02; Flags: ignoreversion overwritereadonly recursesubdirs createallsubdirs sortfilesbyextension
Source: dummy; DestDir: {app}\data; AfterInstall: Pack(ExpandConstant('{app}\data\test02')); Flags: deleteafterinstall

[Code]
#define A = (Defined UNICODE) ? "W" : "A"
const
  WM_GETFONT = $0031;
  WM_SETTEXT = $000C;
  WM_USER    = $0400;

  PBM_SETPOS     = WM_USER + 2;
  PBM_SETRANGE32 = WM_USER + 6;

  GWL_STYLE = -16;

  WS_CLIPSIBLINGS = $04000000;
  WS_VISIBLE      = $10000000;
  WS_CHILDWINDOW  = $40000000;
  SS_RIGHT = $2;

  CP_ACP  = 0;
  CP_UTF8 = 65001;

  FNAME_MAX32 = 512;
  MAX_PATH = 260;

  ARCEXTRACT_BEGIN     = 0;
  ARCEXTRACT_INPROCESS = 1;

type
  { 7-zip.dll. }
  TExtractingInfo = record
    szSourceFileName: PAnsiChar;
    szDestFileName: PAnsiChar;
    dwFileSize: DWORD;
    szFileSize: PAnsiChar;
    dwWriteSize: DWORD;
    szWriteSize: PAnsiChar;
    dwProgress: DWORD;
    szSpeed: PAnsiChar;
    szElapsed: PAnsiChar;
    szRemain: PAnsiChar;
  end;

  { User-defined data passed to callback. }
  TArcParam = array of HWND;

#ifndef IS_ENHANCED
  TPackCallbackProc = function (nState: UINT; var ExtInfo: TExtractingInfo; var ArcParam: TArcParam): BOOL;
#endif

// Unicode and Character Set Functions
function WideCharToMultiByte(CodePage: UINT; dwFlags: DWORD; lpWideCharStr: string; cchWideChar: Integer; lpMultiByteStr: AnsiString; cbMultiByte, lpDefaultChar: Integer; lpUsedDefaultChar: Longint): Integer; external 'WideCharToMultiByte@kernel32.dll stdcall';
function MultiByteToWideChar(CodePage: UINT; dwFlags: DWORD; lpMultiByteStr: AnsiString; cbMultiByte: Integer; lpWideCharStr: string; cchWideChar: Integer): Integer; external 'MultiByteToWideChar@kernel32.dll stdcall';
// Shell Lightweight Utility Functions
function PathCompactPath(hDC: THandle; lpszPath: string; dx: UINT): BOOL; external 'PathCompactPath{#A}@shlwapi.dll stdcall';
// Painting and Drawing Functions
function GetDC(hWnd: HWND): THandle; external 'GetDC@user32.dll stdcall';
// Device Context Functions
function ReleaseDC(hWnd: HWND; hDC: THandle): Integer; external 'ReleaseDC@user32.dll stdcall';
function SelectObject(hdc, hgdiobj: THandle): THandle; external 'SelectObject@gdi32.dll stdcall';
// Window Functions
function GetClientRect(hWnd: HWND; var lpRect: TRect): BOOL; external 'GetClientRect@user32.dll stdcall';
// Message Functions
function SendMessageString(hWnd: HWND; Msg: UINT; wParam: Longint; lParam: string): Longint; external 'SendMessage{#A}@user32.dll stdcall';
// Window Class Functions
function SetWindowLong(hWnd: HWND; nIndex: Integer; dwNewLong: Longint): Longint; external 'SetWindowLong{#A}@user32.dll stdcall';
// 7-zip.dll Functions
function SevenZip(const CmdLine: AnsiString; ArcProc: Longint; var LParam: TArcParam): Integer; external 'SevenZip@files:7-zip32.dll stdcall';
#ifndef IS_ENHANCED
// CallbackCtrl.dll Functions
function WrapPackProc(Callback: TPackCallbackProc; ParamCount: Integer): LongWord; external 'wrapcallbackaddr@files:callbackctrl.dll stdcall';
#endif

var
  ProgressInfoContainer, ProgressInfo: TNewStaticText;
  ArcProc: LongWord;

function UTF8Encode(const Value: string): AnsiString;
var
  Len: Integer;
  UTF16Buffer: string;
begin
  if Value = '' then Exit;
#ifndef UNICODE
  // на ANSI-версии компилятора сначала переводим строку в UTF-16LE (Unicode)
  Len := MultiByteToWideChar(CP_ACP, 0, Value, -1, '', 0);
  if Len = 0 then Exit;
  UTF16Buffer := StringOfChar(#0, Len shl 1);
  if MultiByteToWideChar(CP_ACP, 0, Value, -1, UTF16Buffer, Len) = 0 then Exit;
#else
  UTF16Buffer := Value;
#endif
  // перевод строки UTF-16LE (Unicode) в UTF-8
  Len := WideCharToMultiByte(CP_UTF8, 0, UTF16Buffer, -1, '', 0, 0, 0);
  if Len = 0 then Exit;
  Result := StringOfChar(#0, Len - 1);
  if WideCharToMultiByte(CP_UTF8, 0, UTF16Buffer, -1, Result, Len, 0, 0) = 0 then Exit;
end;

function UTF8Decode(const Value: AnsiString): string;
var
  Len: Integer;
#ifndef UNICODE
  UTF16Buffer: string;
#endif
begin
  if Value = '' then Exit;
#ifndef UNICODE
  // на ANSI-версии компилятора сначала переводим строку в UTF-16LE (Unicode)
  Len := MultiByteToWideChar(CP_UTF8, 0, Value, -1, '', 0);
  if Len = 0 then Exit;
  UTF16Buffer := StringOfChar(#0, Len shl 1);
  if MultiByteToWideChar(CP_UTF8, 0, Value, -1, UTF16Buffer, Len) = 0 then Exit;

  // перевод строки UTF-16 в ANSI
  Len := WideCharToMultiByte(CP_ACP, 0, UTF16Buffer, -1, '', 0, 0, 0);
  if Len = 0 then Exit;
  Result := StringOfChar(#0, Len - 1);
  if WideCharToMultiByte(CP_ACP, 0, UTF16Buffer, -1, Result, Len, 0, 0) = 0 then Exit;
#else
  // на Unicode-версии компилятора перевод строки UTF-8 в UTF-16LE (Unicode)
  Len := MultiByteToWideChar(CP_UTF8, 0, Value, -1, '', 0);
  if Len = 0 then Exit;
  Result := StringOfChar(#0, Len - 1);
  if MultiByteToWideChar(CP_UTF8, 0, Value, -1, Result, Len) = 0 then Exit;
#endif
end;

function PackCallbackProc(nState: UINT; var ExtInfo: TExtractingInfo; var ArcParam: TArcParam): BOOL;
var
  S: string;
  DC, SaveFont: THandle;
  H: HWND;
  R: TRect;
begin
  { Avoid call VCL methods or get/set properties. }
  Result := True;
  case nState of
    ARCEXTRACT_BEGIN:
      begin
        H := ArcParam[0];
        DC := GetDC(H);
        try
          SaveFont := SelectObject(DC, SendMessage(H, WM_GETFONT, 0, 0));
          GetClientRect(H, R);
          S := UTF8Decode(ExtInfo.szDestFileName);
          PathCompactPath(DC, S, R.Right - R.Left);
          SendMessageString(H, WM_SETTEXT, 0, S);
        finally
          if SaveFont <> 0 then
            SelectObject(DC, SaveFont);
          ReleaseDC(H, DC);
        end;
      end;
    ARCEXTRACT_INPROCESS:
      begin
        H := ArcParam[1];
        PostMessage(H, PBM_SETRANGE32, 0, 100);
        PostMessage(H, PBM_SETPOS, ExtInfo.dwProgress, 0);
        H := ArcParam[2];
        S := FmtMessage(CustomMessage('SevenZipProgressInfo'), [IntToStr(ExtInfo.dwProgress), ExtInfo.szWriteSize, ExtInfo.szFileSize, ExtInfo.szSpeed, ExtInfo.szElapsed, ExtInfo.szRemain]);
        SendMessageString(H, WM_SETTEXT, 0, S);
      end;
  end;
end;

procedure Pack(const APath: string);
var
  CmdLine: AnsiString;
  ArcParam: TArcParam;
  ResultCode: Integer;
begin
  { Pack files. }
  try
    WizardForm.StatusLabel.Caption := FmtMessage(CustomMessage('SevenZipStatusPackFiles'), [ExtractFileName(APath)]);
    ProgressInfoContainer.Show;
    CmdLine := UTF8Encode(Format('a -tzip -sdel -y "%0:s.pk3" "%0:s\*"', [APath]));
    SetLength(ArcParam, 3);
    ArcParam[0] := WizardForm.FilenameLabel.Handle;
    ArcParam[1] := WizardForm.ProgressGauge.Handle;
    ArcParam[2] := ProgressInfo.Handle;
    ResultCode := SevenZip(CmdLine, ArcProc, ArcParam);
    if ResultCode <> 0 then
      RaiseException(FmtMessage(CustomMessage('SevenZipPackFailed'), [ExtractFileName(APath), Format('0x%.8x', [ResultCode])]));
    if not RemoveDir(APath) then
    begin
      ResultCode := DLLGetLastError;
      RaiseException(FmtMessage(CustomMessage('UnableDeleteEmptyFolder'), [APath, ResultCode, SysErrorMessage(ResultCode)]));
    end;
  except
    ShowExceptionMessage;
    DelTree(ExtractFileDir(APath) + '\*.pk3', False, True, False);  // Rollback if error occured.
  finally
    ProgressInfoContainer.Hide;
    WizardForm.StatusLabel.Caption := SetupMessage(msgStatusExtractFiles);
    WizardForm.FilenameLabel.Caption := '';
  end;
end;

procedure CreateInstallingPage;
begin
  { ProgressInfoContainer. }
  ProgressInfoContainer := TNewStaticText.Create(WizardForm);
  with ProgressInfoContainer do
  begin
    Parent := WizardForm.InstallingPage;
    Align := alBottom;
    AutoSize := False;
    Caption := CustomMessage('SevenZipProgressCaptions');
    Height := Parent.ClientHeight - WizardForm.ProgressGauge.Top - WizardForm.ProgressGauge.Height - ScaleY(5);
  end;

  { ProgressInfo. }
  ProgressInfo := TNewStaticText.Create(WizardForm);
  with ProgressInfo do
  begin
    Parent := ProgressInfoContainer;
    Align := alRight;
    AutoSize := False;
    Width := Parent.ClientWidth div 2;
    SetWindowLong(Handle, GWL_STYLE, WS_CHILDWINDOW or WS_VISIBLE or WS_CLIPSIBLINGS or SS_RIGHT);
  end;
#ifdef IS_ENHANCED
  ArcProc := CallbackAddr('PackCallbackProc');
#else
  ArcProc := WrapPackProc(@PackCallbackProc, 3);
#endif
end;

procedure InitializeWizard;
begin
  CreateInstallingPage;
end;