STRATEG1992
Junior Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
[Code]
const
Archives = '{src}\*.arc'; // укажите расположение архивов FreeArc; для внешних файлов строку в [Files] добавлять необязательно
PM_REMOVE = 1;
CP_ACP = 0; CP_UTF8 = 65001;
oneMB=1024*1024;
Period = 250; // частота обновления кнопки таскбара и строки статуса
HC_ACTION = 0;
VK_ESCAPE = 27;
WM_PAINT = $F;
WH_CALLWNDPROC = 4;
type
#ifdef UNICODE ;// если у вас ошибка на этой строке, то установите препроцессор или исправьте скрипт для вашей версии Inno Setup
#define A "W"
#else
#define A "A" ;// точка входа в SetWindowText, {#A} меняется на A или W в зависимости от версии
PAnsiChar = PChar; // Required for Inno Setup 5.3.0 and higher. (требуется для Inno Setup версии 5.3.0 и ниже)
#endif
#if Ver < 84018176
AnsiString = String; // There is no need for this line in Inno Setup 5.2.4 and above (для Inno Setup версий 5.2.4 и выше эта строка не нужна)
#endif
TMyMsg = record
hwnd: HWND;
message: UINT;
wParam: Longint;
lParam: Longint;
time: DWORD;
pt: TPoint;
end;
TFreeArcCallback = function (what: PAnsiChar; int1, int2: Integer; str: PAnsiChar): Integer;
TArc = record Path: string; Size: Extended; end;
TBarInfo = record stage, name: string; size: Extended; count, perc, pos, time: Integer; end;
TCWPSTRUCT = record lParam: LongWord; wParam: Word; Msg: LongWord; hwnd: HWnd; end;
TCWPSTRUCTProc = procedure(Code: Integer; wParam: Word; lParam: TCWPSTRUCT);
TTimerProc = procedure(HandleW, Msg, idEvent, TimeSys: LongWord);
var
ExtractFile, StatusInfo: TLabel;
btnCancelUnpacking: TButton;
ProgressBar: TNewProgressBar;
CancelCode, n, ArcInd, UnPackError, StartInstall: Integer;
Arcs: array of TArc;
FSR: TFindRec;
msgError: string;
lastMb, baseMb: Integer;
LastTimerEvent: DWORD;
WndHookID, TimerID: LongWord;
allSize: Extended;
Status: TBarInfo;
FreezeTimer: Boolean;
function WrapFreeArcCallback (callback: TFreeArcCallback; paramcount: integer):longword; external 'wrapcallback@files:innocallback.dll stdcall';
function FreeArcExtract (callback: longword; cmd1,cmd2,cmd3,cmd4,cmd5,cmd6,cmd7,cmd8,cmd9,cmd10: PAnsiChar): integer; external 'FreeArcExtract@files:unarc.dll cdecl';
Function OemToChar(lpszSrc, lpszDst: AnsiString): longint; external 'OemToCharA@user32.dll stdcall';
Function MultiByteToWideChar(CodePage: UINT; dwFlags: DWORD; lpMultiByteStr: PAnsiChar; cbMultiByte: integer; lpWideCharStr: PAnsiChar; cchWideChar: integer): longint; external 'MultiByteToWideChar@kernel32.dll stdcall';
Function WideCharToMultiByte(CodePage: UINT; dwFlags: DWORD; lpWideCharStr: PAnsiChar; cchWideChar: integer; lpMultiByteStr: PAnsiChar; cbMultiByte: integer; lpDefaultChar: integer; lpUsedDefaultChar: integer): longint; external 'WideCharToMultiByte@kernel32.dll stdcall';
function PeekMessage(var lpMsg: TMyMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): BOOL; external 'PeekMessageA@user32.dll stdcall';
function TranslateMessage(const lpMsg: TMyMsg): BOOL; external 'TranslateMessage@user32.dll stdcall';
function DispatchMessage(const lpMsg: TMyMsg): Longint; external 'DispatchMessageA@user32.dll stdcall';
function GetTickCount: DWord; external 'GetTickCount@kernel32';
function GetWindowLong(hWnd, nIndex: Integer): Longint; external 'GetWindowLongA@user32 stdcall delayload';
function SetWindowText(hWnd: Longint; lpString: String): Longint; external 'SetWindowText{#A}@user32 stdcall delayload';
function GetKeyState(nVirtKey: Integer): ShortInt; external 'GetKeyState@user32 stdcall delayload';
function GetCurrentThreadId: LongWord; external 'GetCurrentThreadId@kernel32 stdcall delayload';
function CallNextWNDPROC(idHook: LongWord; Code: Integer; wParam: Word; lParam: TCWPSTRUCT): LongWord; external 'CallNextHookEx@user32 stdcall delayload';
function SetWindowsHookEx(idHook: LongWord; callback: LongWord; hMod: LongWord; dwThreadID: HWND): LongWord; external 'SetWindowsHookExW@user32 stdcall delayload';
function UnhookWindowsHookEx(idHook: LongWord): LongWord; external 'UnhookWindowsHookEx@user32 stdcall delayload';
function WrapCWPSTRUCTProc(callback:TCWPSTRUCTProc; paramcount:integer): longword; external 'wrapcallback@files:innocallback.dll';
function WrapTimerProc(callback: TTimerProc; Paramcount: Integer): longword; external 'wrapcallback@files:innocallback.dll stdcall';
function SetTimer(hWnd, nIDEvent, uElapse, lpTimerFunc: LongWord): longword; external 'SetTimer@user32';
function KillTimer(hWnd, nIDEvent: LongWord): LongWord; external 'KillTimer@user32 stdcall delayload';
procedure AppProcessMessage;
var
Msg: TMyMsg;
begin
while PeekMessage(Msg, WizardForm.Handle, 0, 0, PM_REMOVE) do begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
// Sets the TaskBar title
Procedure SetTaskBarTitle(Title: String); var h: Integer;
Begin
h:= GetWindowLong(MainForm.Handle, -8); if h <> 0 then SetWindowText(h, Title);
End;
// Перевод числа в строку с точностью 2 знака (%.2n) с округлением дробной части, если она есть
Function NumToStr(Float: Extended): String;
Begin
Result:= Format('%.2n', [Float]); StringChange(Result, ',', '.');
while ((Result[Length(Result)] = '0') or (Result[Length(Result)] = '.')) and (Pos('.', Result) > 0) do
SetLength(Result, Length(Result)-1);
End;
Function ByteOrTB(Bytes: Extended; noMB: Boolean): String; {Перевод числа в значение бт/Кб/Мб/Гб/Тб (до 2х знаков после запятой)}
Begin
if not noMB then Result:= NumToStr(Int(Bytes)) +' Mb' else
if Bytes < 1024 then if Bytes = 0 then Result:= '0' else Result:= NumToStr(Int(Bytes)) +' Bt' else
if Bytes/1024 < 1024 then Result:= NumToStr(round((Bytes/1024)*10)/10) +' Kb' else
If Bytes/oneMB < 1024 then Result:= NumToStr(round(Bytes/oneMB*100)/100) +' Mb' else
If Bytes/oneMB/1000 < 1024 then Result:= NumToStr(round(Bytes/oneMB/1024*1000)/1000) +' Gb' else
Result:= NumToStr(round(Bytes/oneMB/oneMB*1000)/1000) +' Tb';
End;
// Converts milliseconds to human-readable time
// Конвертирует милисекунды в человеко-читаемое изображение времени
Function TicksToTime(Ticks: DWord; h,m,s: String; detail: Boolean): String;
Begin
if detail then {hh:mm:ss format}
Result:= PADZ(IntToStr(Ticks/3600000), 2) +':'+ PADZ(IntToStr((Ticks/1000 - Ticks/1000/3600*3600)/60), 2) +':'+ PADZ(IntToStr(Ticks/1000 - Ticks/1000/60*60), 2)
else if Ticks/3600 >= 1000 then {more than hour}
Result:= IntToStr(Ticks/3600000) +h+' '+ PADZ(IntToStr((Ticks/1000 - Ticks/1000/3600*3600)/60), 2) +m
else if Ticks/60 >= 1000 then {1..60 minutes}
Result:= IntToStr(Ticks/60000) +m+' '+ IntToStr(Ticks/1000 - Ticks/1000/60*60) +s
else Result:= Format('%.1n', [Abs(Ticks/1000)]) +s {less than one minute}
End;
function cm(Message: String): String; Begin Result:= ExpandConstant('{cm:'+ Message +'}') End;
Function LoWord(lw: LongWord): LongWord; Begin Result:= lw shr 16; End;
Function Size64(Hi, Lo: Integer): Extended;
Begin
Result:= Lo;
if Lo<0 then Result:= Result + $7FFFFFFF + $7FFFFFFF + 2;
for Hi:= Hi-1 Downto 0 do
Result:= Result + $7FFFFFFF + $7FFFFFFF + 2;
End;
// Converts OEM encoded string into ANSI
// Преобразует OEM строку в ANSI кодировку
function OemToAnsiStr(strSource: AnsiString): AnsiString;
var
nRet : longint;
begin
SetLength(Result, Length(strSource));
nRet:= OemToChar(strSource, Result);
end;
// Converts ANSI encoded string into UTF-8
// Преобразует строку из ANSI в UTF-8 кодировку
function AnsiToUtf8(strSource: string): string;
var
nRet, nRet2: integer; WideCharBuf, MultiByteBuf: AnsiString;
begin
SetLength(WideCharBuf, Length(strSource) * 2);
SetLength(MultiByteBuf, Length(strSource) * 2);
nRet:= MultiByteToWideChar(CP_ACP, 0, strSource, -1, WideCharBuf, Length(WideCharBuf));
nRet2:= WideCharToMultiByte(CP_UTF8, 0, WideCharBuf, -1, MultiByteBuf, Length(MultiByteBuf), 0, 0);
if nRet * nRet2 = 0 then Result:= strSource else Result:= MultiByteBuf;
end;
// OnClick event function for btnCancel
procedure btnCancelUnpackingOnClick(Sender: TObject);
begin
FreezeTimer:= true; // заблокировать таймер
if MsgBox(SetupMessage(msgExitSetupMessage), mbInformation, MB_YESNO) = IDYES then
CancelCode:= -127 else FreezeTimer:= false; // продолжить обновление информации
end;
// Scans the specified folders for archives and add them to list
function FindArcs(dir: string): Extended;
Begin
Result:= 0;
if FindFirst(ExpandConstant(dir), FSR) then
try
repeat
// Skip everything but the folders
if FSR.Attributes and FILE_ATTRIBUTE_DIRECTORY > 0 then CONTINUE;
n:= GetArrayLength(Arcs);
// Expand the folder list
SetArrayLength(Arcs, n +1);
Arcs[n].Path:= ExtractFilePath(ExpandConstant(dir)) + FSR.Name;
Arcs[n].Size:= Size64(FSR.SizeHigh, FSR.SizeLow);
Result:= Result + Arcs[n].Size;
until not FindNext(FSR);
finally
FindClose(FSR);
end;
End;
Procedure UpdateStatus(); // выполняется с переодичностью, заданной константой Period
var
Remaining: Integer; i, t, s: string;
Begin
if (GetTickCount - LastTimerEvent <= Period) or FreezeTimer then Exit else LastTimerEvent := GetTickCount;
with WizardForm.ProgressGauge do begin
if position > 0 then Remaining:= trunc((GetTickCount - StartInstall) * Abs((max - position)/position)) else Remaining:= 0;
t:= cm('ending'); i:= t;
if Remaining > 0 then begin
t:= FmtMessage(cm('taskbar'), [IntToStr(Status.perc/10), TicksToTime(Remaining, 'h', 'm', 's', false)])
i:= TicksToTime(Remaining, cm('hour'), cm('min'), cm('sec'), false)
end;
end;
SetTaskBarTitle(t); // проценты и оставшееся время на кнопке инсталлятора
if Status.size > 0 then
s:= ' [' + ByteOrTB(Status.size*oneMB, true) + ']'; // можно сделать подсчёт размера папки {app} через CalcDirSize, но это может замедлить работу
StatusInfo.Caption:= FmtMessage(cm('StatusInfo'), [IntToStr(Status.count), s, Format('%.1n', [Abs(Status.perc/10)]), i]);
if GetArrayLength(Arcs) > 1 then begin // показать прогрессбар и сведения при обработке нескольких архивов
ExtractFile.Caption:= FmtMessage(cm('ArcInfo'), [IntToStr(ArcInd+1), IntToStr(GetArrayLength(Arcs)), ByteOrTB(Arcs[ArcInd].Size, true), Format('%.0n', [Status.pos/(Arcs[ArcInd].Size/oneMB)*100]), ByteOrTB(allSize, true)])
ProgressBar.Position:= round(ProgressBar.Max * Status.pos/(Arcs[ArcInd].Size/oneMB))
if not ProgressBar.Visible then ProgressBar.Show;
end;
End;
Procedure MyTimerProc(h, msg, idevent, dwTime: Longword);
Begin
UpdateStatus;
End;
Procedure OnWndHook(Code: Integer; wParam: Word; lParam: TCWPSTRUCT);
Begin
if (Code = HC_ACTION) and (LoWord(lParam.msg) = WM_PAINT) then begin //подготовка данных для последующего отображения по таймеру
if Status.name <> WizardForm.FileNameLabel.Caption then // реагируем только на этапы извлечения файлов и распаковки архивов
if (WizardForm.StatusLabel.Caption = SetupMessage(msgStatusExtractFiles)) or (WizardForm.StatusLabel.Caption = cm('ArcTitle')) then begin
Status.name := WizardForm.FileNameLabel.Caption;
Status.count:= Status.count + 1; // кол-во файлов
end;
with WizardForm.ProgressGauge do
Status.perc:= (Position-Min)/((Max - Min)/1000); // 1000 процентов
UpdateStatus();
end;
CallNextWNDPROC(WndHookID, Code, wParam, lParam) {освобождение события}
End;
// The main callback function for unpacking FreeArc archives
function FreeArcCallback (what: PAnsiChar; Mb, sizeArc: Integer; str: PAnsiChar): Integer;
var
Elapsed: Extended;
begin
// if GetTickCount - LastTimerEvent > 1000 then begin
// This code will be executed once each 1000 ms (этот код будет выполняться раз в 1000 миллисекунд)
UpdateStatus();
if GetKeyState(VK_ESCAPE) < 0 then btnCancelUnpacking.OnClick(btnCancelUnpacking);
// End of code executed by timer
// LastTimerEvent := LastTimerEvent+1000;
// end;
Case string(what) of
'filename': begin // Update FileName label
WizardForm.FileNameLabel.Caption:= OemToAnsiStr(str); // извлекаемый файл
end;
'progress': if Mb >= 1 then with WizardForm.ProgressGauge do begin
for n:= 0 to ArcInd-1 do Elapsed:= Elapsed + Arcs[n].Size; Elapsed:= Elapsed/oneMB + Mb; // обработано Mбайт (для небольшого архива точность страдает)
Position:= round(Max * Elapsed/(allSize/oneMB))
Status.pos := Mb; // позиция в текущем архиве
end;
'written': begin // Assign to Mb *total* amount of data extracted to the moment from all archives
lastMb := Mb; // извлечено из текущего архива
Status.size := baseMb+Mb; // запоминаем общий объём, чтобы снимать данные по таймеру
end;
End;
AppProcessMessage;
Result:= CancelCode;
end;
// Extracts all found archives
function UnPack(Archives: string): Integer;
var
callback: longword;
FreeMB, TotalMB: Cardinal;
begin
// Show the 'Cancel unpacking' button and set it as default button
btnCancelUnpacking.Show;
WizardForm.ActiveControl:= btnCancelUnpacking;
// Get the size of all archives
allSize:= FindArcs(Archives);
// Other initializations
callback:= WrapFreeArcCallback(@FreeArcCallback,4); //FreeArcCallback has 4 arguments
WizardForm.StatusLabel.Caption:= cm('ArcTitle'); // начало этапa распаковки
baseMb:= 0 // обнулить полученные мегабайты, если ранее вёлся подсчёт объёма файлов инсталлятора
LastTimerEvent := 0; // сброс таймера, чтобы игнорировать предыдущую задержку и немедленно обновить строку статуса
Status.count:= 0; // не учитывать файлы, извлечённые инсталлятором
for ArcInd:= 0 to GetArrayLength(Arcs) -1 do begin
CancelCode:= 0;
AppProcessMessage;
try
// Pass the specified arguments to 'unarc.dll'
Result:= FreeArcExtract (callback, 'x', '-o+', '-dp'+ AnsiToUtf8(ExpandConstant('{app}')), '--', AnsiToUtf8(Arcs[ArcInd].Path), '', '', '', '', '');
if CancelCode < 0 then Result:= CancelCode;
except
Result:= -63; // ArcFail
end;
baseMb:= baseMb + lastMb // общий объём распакованных файлов
// Error occured
if Result <> 0 then
begin
msgError:= FmtMessage(cm('ArcError'), [IntToStr(Result)]);
WizardForm.StatusLabel.Caption:= msgError;
WizardForm.FileNameLabel.Caption:= ExtractFileName(Arcs[ArcInd].Path);
GetSpaceOnDisk(ExtractFileDrive(ExpandConstant('{app}')), True, FreeMB, TotalMB);
case Result of
-1: if FreeMB < 32 {Мб на диске} then msgError:= SetupMessage(msgDiskSpaceWarningTitle)
else msgError:= msgError + #13#10 + FmtMessage(cm('ArcBroken'), [ExtractFileName(Arcs[ArcInd].Path)]);
-127: msgError:= cm('ArcBreak'); //Cancel button
-63: msgError:= cm('ArcFail');
end;
// MsgBox(msgError, mbInformation, MB_OK); // диалог не нужен, т.к. ошибка показывается на странице завершения
Log(msgError);
Break; // прервать цикл распаковки
end;
end;
// Hide labels and button
btnCancelUnpacking.Hide;
StatusInfo.Visible:= false;
ExtractFile.Visible:= false;
ProgressBar.Hide;
end;
procedure CurStepChanged(CurStep: TSetupStep);
begin
if CurStep = ssInstall then begin
StartInstall:= GetTickCount {время начала извлечения файлов}
WndHookID:= SetWindowsHookEx(WH_CALLWNDPROC, WrapCWPSTRUCTProc(@OnWndHook, 3), 0, GetCurrentThreadId); {установка SendMessage хука}
TimerID:= SetTimer(0, 0, 500 {полсекунды}, WrapTimerProc(@MyTimerProc, 4)); {установка таймера}
end;
if CurStep = ssPostInstall then
begin
StartInstall:= GetTickCount {время начала распаковки}
UnPackError:= UnPack(Archives)
KillTimer(0, TimerID) {удаление таймера}
UnhookWindowsHookEx(WndHookID) {удаление SendMessage хука}
if UnPackError = 0 then
SetTaskBarTitle(SetupMessage(msgSetupAppTitle))
else
begin
// Error occured, uninstall it then
if '{#SetupSetting("Uninstallable")}' <> 'false' then // деинсталляция разрешёна
Exec(ExpandConstant('{uninstallexe}'), '/SILENT','', sw_Hide, ewWaitUntilTerminated, n); // откат установки из-за ошибки unarc.dll
SetTaskBarTitle(SetupMessage(msgErrorTitle))
WizardForm.Caption:= SetupMessage(msgErrorTitle) +' — '+ cm('ArcBreak')
end;
end;
end;
// стандартный способ отката (не нужна CurPageChanged), но архивы распаковываются до извлечения файлов инсталлятора
// if CurStep = ssInstall then
// if UnPack(Archives) <> 0 then Abort;
Procedure CurPageChanged(CurPageID: Integer);
Begin
if (CurPageID = wpFinished) and (UnPackError <> 0) then
begin // Extraction was unsuccessful (распаковщик вернул ошибку)
// Show error message
WizardForm.FinishedLabel.Font.Color:= $0000C0; // red (красный)
WizardForm.FinishedLabel.Height:= WizardForm.FinishedLabel.Height * 2;
WizardForm.FinishedLabel.Caption:= SetupMessage(msgSetupAborted) + #13#10#13#10 + msgError;
end;
End;
procedure InitializeWizard();
begin
with WizardForm.ProgressGauge do begin
// Create controls to show extended info
StatusInfo:= TLabel.Create(WizardForm);
StatusInfo.parent:=WizardForm.InstallingPage;
StatusInfo.Autosize:= false;
StatusInfo.Top:= Top + ScaleY(32);
StatusInfo.Width:= Width;
ProgressBar := TNewProgressBar.Create(WizardForm);
ProgressBar.SetBounds(Left, StatusInfo.Top + StatusInfo.Height + ScaleY(16), Width, Height);
ProgressBar.Parent := WizardForm.InstallingPage;
ProgressBar.max := 65536;
ProgressBar.Hide; // будет показан при обработке нескольких архивов
ExtractFile:= TLabel.Create(WizardForm);
ExtractFile.parent:=WizardForm.InstallingPage;
ExtractFile.Autosize:= false;
ExtractFile.Top:= ProgressBar.Top + ScaleY(32);
ExtractFile.Width:= Width;
end;
// Create a 'Cancel unpacking' button and hide it for now.
btnCancelUnpacking:=TButton.create(WizardForm);
btnCancelUnpacking.Parent:= WizardForm;
btnCancelUnpacking.SetBounds(WizardForm.cancelbutton.left, WizardForm.cancelbutton.top, WizardForm.cancelbutton.width, WizardForm.cancelbutton.height);
btnCancelUnpacking.OnClick:= @btnCancelUnpackingOnClick;
btnCancelUnpacking.Caption:= SetupMessage(msgButtonCancel);
btnCancelUnpacking.Hide;
end;
Procedure DeInitializeSkin;
Begin
UnhookWindowsHookEx(WndHookID) {удаление SendMessage хука}
KillTimer(0, TimerID) {удаление таймера}
End; |
