Victor_Dobrov
Advanced Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Код: [Setup]
AppName=FreeArc Example
AppVerName=FreeArc Example 1.2
DefaultDirName={pf}\FreeArc Example
UsePreviousAppDir=false
DirExistsWarning=no
ShowLanguageDialog=auto
OutputBaseFilename=FreeArcExampleTimer
OutputDir=.
VersionInfoCopyright=Bulat Ziganshin, Victor Dobrov, SotM, CTACKo
[Languages]
Name: eng; MessagesFile: compiler:Default.isl
Name: rus; MessagesFile: compiler:Languages\Russian.isl
[CustomMessages]
eng.ArcCancel=Cancel installation
eng.ArcBreak=Installation cancelled!
eng.ArcInfo=Extracted %1 Mb of %2 Mb (%3%%). Archive: %4 of %5.
eng.ArcTitle=Extracting FreeArc archive
eng.ArcError=Decompression failed with error code %1
eng.ArcFail=Decompression failed!
eng.AllProgress=Overall extraction progress: %1%%
eng.ArcBroken=Archive %1 is damaged%nor not enough free space.
eng.Extracting=Extracting: %1
eng.remains=%1%%, %2 elapsed
eng.LongTime=at no time
eng.ending=ending
rus.ArcCancel=Отменить распаковку
rus.ArcBreak=Установка прервана!
rus.ArcInfo=Распаковано %1 Мб из %2 Мб (%3%%). Архив: %4 из %5.
rus.ArcTitle=Распаковка архивов FreeArc
rus.ArcError=Распаковщик FreeArc вернул код ошибки: %1
rus.ArcFail=Распаковка не завершена!
rus.AllProgress=Общий прогресс распаковки: %1%%
rus.ArcBroken=Возможно, архив %1 повреждён%nили недостаточно места на диске назначения.
rus.Extracting=Распаковывается: %1
rus.remains=%1%%, жди %2
rus.LongTime=вечно
rus.ending=завершение
[Files]
;Source: *.arc; DestDir: {app}; Flags: nocompression
Source: unarc.dll; DestDir: {tmp}; Flags: dontcopy deleteafterinstall
Source: compiler:InnoCallback.dll; DestDir: {tmp}; Flags: dontcopy
Source: {win}\inf\*; DestDir: {app}\inf; Flags: external deleteafterinstall
[UninstallDelete]
Type: filesandordirs; Name: {app}
[Code]
var Debug: TForm; Dl: TMemo; cDebug: boolean;
Procedure D(S: string); begin
if not cDebug then begin Debug:= CreateCustomForm; Debug.SetBounds(8, 4, 540, 580) Debug.Show Dl:=TMemo.Create(Debug) Dl.Align:= alClient; Dl.ScrollBars:= ssVertical; Dl.WantReturns:= False; Dl.Parent:= Debug; cDebug:= true end;
if Dl.Lines.Text = '' then Dl.Lines.Text:= S else Dl.Lines.Insert(Dl.Lines.Count, S)
End;
Procedure Df(S: Extended); begin D(FloatToStr(S)) End;
Function MultiByteToWideChar(CodePage: UINT; dwFlags: DWORD; lpMultiByteStr: string; cbMultiByte: integer; lpWideCharStr: string; cchWideChar: integer): longint; external 'MultiByteToWideChar@kernel32.dll stdcall';
Function WideCharToMultiByte(CodePage: UINT; dwFlags: DWORD; lpWideCharStr: string; cchWideChar: integer; lpMultiByteStr: string; cbMultiByte: integer; lpDefaultChar: integer; lpUsedDefaultChar: integer): longint; external 'WideCharToMultiByte@kernel32.dll stdcall';
const
Archives = '{src}\*.arc'; // укажите расположение архивов FreeArc; для внешних файлов строку в [Files] добавлять необязательно
PM_REMOVE = 1;
CP_ACP = 0; CP_UTF8 = 65001;
type
#ifdef UNICODE ; если у вас ошибка на этой строке, то установите препроцессор или исправьте скрипт для вашей версии Inno Setup
#define A "W"
#else
#define A "A" ; точка входа в SetWindowText, {#A} меняется на A или W в зависимости от версии
PAnsiChar = PChar; // требуется для Inno Setup версии 5.3.0 и ниже
#endif
#if Ver < 84018176
AnsiString = String; // для 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;
TTimerProc = procedure(HandleW, Msg, idEvent, TimeSys: LongWord);
var
ProgressBar: TNewProgressBar;
ExtractFile: TNewStaticText;
lblExtractFileName: TLabel;
btnCancelUnpacking: TButton;
CancelCode, n, UnPackError, StartInstall: Integer;
Arcs: array of TArc;
TimerID: Longword;
msgError: string;
m: Extended;
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 OemToChar(lpszSrc, lpszDst: AnsiString): longint; external 'OemToCharA@user32.dll stdcall';
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 GetTickCount: DWord; external 'GetTickCount@kernel32';
function KillTimer(hWnd, nIDEvent: LongWord): LongWord; external 'KillTimer@user32';
function SetTimer(hWnd, nIDEvent, uElapse, lpTimerFunc: LongWord): longword; external 'SetTimer@user32';
function WrapTimerProc(callback: TTimerProc; Paramcount: Integer): longword; external 'wrapcallback@files:innocallback.dll stdcall';
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';
procedure AppProcessMessage;
var
Msg: TMyMsg;
begin
while PeekMessage(Msg, WizardForm.Handle, 0, 0, PM_REMOVE) do begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
Function NumToStr(Float: Extended): String; {Перевод числа в строку с точностью 3 знака (%.3n) с округлением дробной части, если она есть}
Begin
Result:= Format('%.3n', [Float]); StringChange(Result, ',', '.'); while ((Result[Length(Result)] = '0') or (Result[Length(Result)] = '.')) and (Length(Result) > 1) do SetLength(Result, Length(Result)-1);
End;
function cm(Message: String): String; Begin Result:= ExpandConstant('{cm:'+ Message +'}') 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;
procedure btnCancelUnpackingOnClick(Sender: TObject);
begin
if MsgBox( SetupMessage( msgExitSetupMessage ), mbInformation, MB_YESNO ) = IDYES then
CancelCode:= -127;
end;
function FindArcs(dir: string): Extended;
var
FSR: TFindRec;
Begin
if FindFirst(ExpandConstant(dir), FSR) then
try
repeat
if FSR.Attributes and FILE_ATTRIBUTE_DIRECTORY > 0 then CONTINUE;
n:= GetArrayLength(Arcs);
SetArrayLength(Arcs, n +1);
Arcs[n].Path:= ExtractFilePath(ExpandConstant(Archives)) + FSR.Name;
Arcs[n].Size:= Size64(FSR.SizeHigh, FSR.SizeLow);
Result:= Result + Arcs[n].Size;
until not FindNext(FSR);
finally
FindClose(FSR);
end;
End;
// Преобразует OEM строку в ANSI кодировку
function OemToAnsiStr( strSource: AnsiString): AnsiString;
var
nRet : longint;
begin
SetLength( Result, Length( strSource ) );
nRet:= OemToChar( strSource, Result );
end;
// Преобразует строку из ANSI в UTF-8 кодировку
function AnsiToUtf8( strSource: string ): string;
var
nRet : integer;
WideCharBuf: string;
MultiByteBuf: string;
begin
strSource:= strSource + chr(0);
SetLength( WideCharBuf, Length( strSource ) * 2 );
SetLength( MultiByteBuf, Length( strSource ) * 2 );
nRet:= MultiByteToWideChar( CP_ACP, 0, strSource, -1, WideCharBuf, Length(WideCharBuf) );
nRet:= WideCharToMultiByte( CP_UTF8, 0, WideCharBuf, -1, MultiByteBuf, Length(MultiByteBuf), 0, 0);
Result:= MultiByteBuf;
end;
Procedure SetTaskBarTitle(Title: String); var h: Integer;
Begin
h:= GetWindowLong(MainForm.Handle, -8); if h <> 0 then SetWindowText(h, Title);
End;
Function TicksToTime(Ticks: DWord; detail: Boolean): String; Begin {милисекунды в стандартное время}
if detail or (Ticks/3600 >= 1000) {hour} then if Ticks/3600000 > 23 then Result:= cm('LongTime') else 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/60 < 1000 {min} then Result:= IntToStr(Ticks/1000) +'.'+ NumToStr(trunc((Ticks/1000 - trunc(Ticks/1000))*10)) +'s' else Result:= IntToStr(Ticks/60000) +'m '+ PADZ(IntToStr(Ticks/1000 - Ticks/1000/60*60), 2) +'s';
End;
{ - - - - - - - - - - ВЫПОЛНЕНИЕ ДЕЙСТВИЙ ПО ТАЙМЕРУ - - - - - - - - - - - }
Procedure MyTimerProc(h, msg, idevent, dwTime: Longword); var Elapsed: Integer;
Begin
with WizardForm.ProgressGauge do begin
if position = 0 then Exit;
Elapsed:= trunc(Abs(max/position)*(GetTickCount - StartInstall)-(GetTickCount - StartInstall))
// df(Elapsed)
if Elapsed = 0 then SetTaskBarTitle(cm('ending')) else SetTaskBarTitle(FmtMessage(cm('remains'), [IntToStr((Position-Min)/((Max - Min)/100)), TicksToTime(Elapsed, false)]));
end;
End;
function FreeArcCallback (what: PAnsiChar; Mb, sizeArc: Integer; str: PAnsiChar): Integer;
var
percents: Integer;
begin
if string(what)='filename' then
lblExtractFileName.Caption:= FmtMessage( cm( 'Extracting' ), [OemToAnsiStr( str )] )
else
if (string(what)='progress') and (sizeArc>0) then
with WizardForm.ProgressGauge do begin
percents:= (Mb*1000) div sizeArc;
ProgressBar.Position:= percents;
ExtractFile.Caption:= FmtMessage(cm('ArcInfo'), [IntToStr(Mb), IntToStr(sizeArc), Format('%.1n', [Abs(percents/10)]), IntToStr(n+1), IntToStr(GetArrayLength(Arcs)) ]);
Position:= Tag + round(ProgressBar.Position * m)
percents:= (Position-Min)/((Max - Min)/1000)
WizardForm.FileNameLabel.Caption:= FmtMessage(cm('AllProgress'), [Format('%.1n', [Abs(percents/10)])]);
end;
AppProcessMessage;
Result:= CancelCode;
end;
function UnPack(Archives: string): Integer;
var
allSize: Extended;
callback: longword;
FreeMB, TotalMB: Cardinal;
begin
btnCancelUnpacking.Show;
WizardForm.ActiveControl:= btnCancelUnpacking;
WizardForm.ProgressGauge.Position:= 0;
WizardForm.ProgressGauge.Max:= 1000;
allSize:= FindArcs(Archives);
for n:= 0 to GetArrayLength(Arcs) -1 do
begin
m:= Arcs[n].Size/allSize; //объём текущего архива
WizardForm.ProgressGauge.Tag:= WizardForm.ProgressGauge.Position;
CancelCode:= 0;
AppProcessMessage;
callback:= WrapFreeArcCallback(@FreeArcCallback,4); //FreeArcCallback has 4 arguments
try
Result:= FreeArcExtract (callback, 'x', '-o+', '-dp' + AnsiToUtf8( ExpandConstant('{app}') ), '--', Arcs[n].Path, '', '', '', '', '');
if Result = 0 then Result:= CancelCode;
except
Result:= -63; // ArcFail
end;
if Result <> 0 then
begin
msgError:= FmtMessage(cm('ArcError'), [IntToStr(Result)]);
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[n].Path)]);
-127: msgError:= cm('ArcBreak'); //Cancel button
-63: msgError:= cm('ArcFail');
end;
// MsgBox(msgError, mbInformation, MB_OK); //сообщение показывается на странице завершения
Log(msgError);
Break; //прервать цикл распаковки
end;
end;
btnCancelUnpacking.visible:= false;
end;
procedure CurStepChanged(CurStep: TSetupStep);
begin
if CurStep = ssInstall then begin
StartInstall:= GetTickCount {время начала распаковки}
TimerID:= SetTimer(0, 0, 500, WrapTimerProc(@MyTimerProc, 4)); {установка таймера}
end;
if CurStep = ssPostInstall then begin
UnPackError:= UnPack(Archives)
KillTimer(0, TimerID) {удаление таймера}
if UnPackError = 0 then SetTaskBarTitle(SetupMessage(msgSetupAppTitle)) else begin
Exec(ExpandConstant('{uninstallexe}'), '/SILENT','', sw_Hide, ewWaitUntilTerminated, n); //откат установки из-за ошибки unarc.dll
SetTaskBarTitle(SetupMessage(msgErrorTitle))
WizardForm.Caption:= cm('ArcFail')
end;
end;
end;
Procedure CurPageChanged(CurPageID: Integer);
Begin
if (CurPageID = wpFinished) and (UnPackError <> 0) then
begin //распаковщик вернул ошибку
WizardForm.FinishedLabel.Font.Color:= $0000C0; //красный
WizardForm.FinishedLabel.Height:= WizardForm.FinishedLabel.Height * 2;
WizardForm.FinishedLabel.Caption:= SetupMessage(msgSetupAborted) + #13#10#13#10 + msgError;
end;
End;
procedure InitializeWizard();
begin
ProgressBar:= TNewProgressBar.Create(WizardForm);
ExtractFile:=TNewStaticText.Create(WizardForm);
lblExtractFileName:= TLabel.Create( WizardForm );
with WizardForm.ProgressGauge do
begin
lblExtractFileName.parent:=WizardForm.InstallingPage;
lblExtractFileName.autosize:=false;
lblExtractFileName.Width:= Width;
lblExtractFileName.top:=Top + ScaleY(35);
lblExtractFileName.Caption:= '';
ExtractFile.parent:=WizardForm.InstallingPage;
ExtractFile.autosize:=false;
ExtractFile.Width:= Width;
ExtractFile.top:=lblExtractFileName.Top + ScaleY(16);
ExtractFile.caption:=cm('ArcTitle');
ProgressBar.SetBounds(Left, ExtractFile.Top + ScaleY(16), Width, Height);
ProgressBar.Parent:= WizardForm.InstallingPage;
ProgressBar.max:= 1000;
ProgressBar.Position:= 0;
end;
btnCancelUnpacking:=TButton.create(WizardForm);
btnCancelUnpacking.Parent:= WizardForm;
btnCancelUnpacking.SetBounds(260, WizardForm.cancelbutton.top, 135, WizardForm.cancelbutton.Height);
btnCancelUnpacking.OnClick:= @btnCancelUnpackingOnClick;
btnCancelUnpacking.Caption:= cm('ArcCancel');
btnCancelUnpacking.Hide;
end; |
|
