Ветеран
Сообщения: 1274
Благодарности: 1030
|
Профиль
|
Отправить PM
| Цитировать
Цитата TROY Diamond:
|
во время упаковки всё замирает, кнопка Отмена НЕ активна, конечный пользователь может решить что всё зависло, а создание некоторых больших архивов может занимает до 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 '[email protected] stdcall';
function MultiByteToWideChar(CodePage: UINT; dwFlags: DWORD; lpMultiByteStr: AnsiString; cbMultiByte: Integer; lpWideCharStr: string; cchWideChar: Integer): Integer; external '[email protected] 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 '[email protected] stdcall';
// Device Context Functions
function ReleaseDC(hWnd: HWND; hDC: THandle): Integer; external '[email protected] stdcall';
function SelectObject(hdc, hgdiobj: THandle): THandle; external '[email protected] stdcall';
// Window Functions
function GetClientRect(hWnd: HWND; var lpRect: TRect): BOOL; external '[email protected] 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;
|
