Inno Setup - How to add multiple arc files to decompress? - inno-setup

I am using this code: Inno Setup - How to add cancel button to decompressing page? (answer of Martin Prikryl) to decompress an arc file with Inno Setup.
I want to have the possibility of decompress more than one arc file to install files from components selection (for example). But still show on overall progress bar for all extractions. whole Is this possible?

This is modification of my answer to Inno Setup - How to add cancel button to decompressing page?
Prerequisities are the same, refer to the other answer.
In the ExtractArc, call AddArchive for each archive you want to extract.
[Files]
Source: unarc.dll; Flags: dontcopy
[Code]
const
ArcCancelCode = -10;
function FreeArcExtract(
Callback: LongWord;
Cmd1, Cmd2, Cmd3, Cmd4, Cmd5, Cmd6, Cmd7, Cmd8, Cmd9, Cmd10: PAnsiChar): Integer;
external 'FreeArcExtract#files:unarc.dll cdecl';
const
CP_UTF8 = 65001;
function WideCharToMultiByte(CodePage: UINT; dwFlags: DWORD;
lpWideCharStr: string; cchWideChar: Integer; lpMultiByteStr: AnsiString;
cchMultiByte: Integer; lpDefaultCharFake: Integer;
lpUsedDefaultCharFake: Integer): Integer;
external 'WideCharToMultiByte#kernel32.dll stdcall';
function GetStringAsUtf8(S: string): AnsiString;
var
Len: Integer;
begin
Len := WideCharToMultiByte(CP_UTF8, 0, S, Length(S), Result, 0, 0, 0);
SetLength(Result, Len);
WideCharToMultiByte(CP_UTF8, 0, S, Length(S), Result, Len, 0, 0);
end;
var
ArcTotalSize: Integer;
ArcTotalExtracted: Integer;
ArcExtracted: Integer;
ArcCancel: Boolean;
ArcProgressPage: TOutputProgressWizardPage;
function FreeArcCallback(
AWhat: PAnsiChar; Int1, Int2: Integer; Str: PAnsiChar): Integer;
var
What: string;
begin
What := AWhat;
if What = 'origsize' then
begin
Log(Format('Adding archive with files with total size %d MB', [Int1]));
ArcTotalSize := ArcTotalSize + Int1;
end
else
if What = 'write' then
begin
if ArcTotalSize > 0 then
begin
ArcProgressPage.SetProgress(ArcTotalExtracted + Int1, ArcTotalSize);
end;
ArcExtracted := Int1;
end
else
begin
// Just to pump message queue more often (particularly for 'read' callbacks),
// to get more smooth progress bar
if (ArcExtracted > 0) and (ArcTotalSize > 0) then
begin
ArcProgressPage.SetProgress(ArcTotalExtracted + ArcExtracted, ArcTotalSize);
end;
end;
if ArcCancel then Result := ArcCancelCode
else Result := 0;
end;
procedure FreeArcCmd(
Cmd1, Cmd2, Cmd3, Cmd4, Cmd5, Cmd6, Cmd7, Cmd8, Cmd9, Cmd10: string);
var
ArcResult: Integer;
begin
ArcCancel := False;
ArcResult :=
FreeArcExtract(
CreateCallback(#FreeArcCallback),
GetStringAsUtf8(Cmd1), GetStringAsUtf8(Cmd2), GetStringAsUtf8(Cmd3),
GetStringAsUtf8(Cmd4), GetStringAsUtf8(Cmd5), GetStringAsUtf8(Cmd6),
GetStringAsUtf8(Cmd7), GetStringAsUtf8(Cmd8), GetStringAsUtf8(Cmd9),
GetStringAsUtf8(Cmd10));
if ArcCancel then
begin
RaiseException('Extraction cancelled');
end
else
if ArcResult <> 0 then
begin
RaiseException(Format('Extraction failed with code %d', [ArcResult]));
end;
end;
var
ArcArchives: array of string;
procedure AddArchive(ArchivePath: string);
begin
SetArrayLength(ArcArchives, GetArrayLength(ArcArchives) + 1);
ArcArchives[GetArrayLength(ArcArchives) - 1] := ArchivePath;
FreeArcCmd('l', '--', ArchivePath, '', '', '', '', '', '', '');
end;
procedure UnPackArchives(DestPath: string);
var
I: Integer;
ArchivePath: string;
begin
Log(Format('Total size of files to be extracted is %d MB', [ArcTotalSize]));
ArcTotalExtracted := 0;
for I := 0 to GetArrayLength(ArcArchives) - 1 do
begin
ArcExtracted := 0;
ArchivePath := ArcArchives[I];
Log(Format('Extracting %s', [ArchivePath]));
FreeArcCmd('x', '-o+', '-dp' + DestPath, '-w' + DestPath, '--', ArchivePath,
'', '', '', '');
ArcTotalExtracted := ArcTotalExtracted + ArcExtracted;
end;
end;
procedure UnpackCancelButtonClick(Sender: TObject);
begin
ArcCancel := True;
end;
procedure ExtractArc;
var
PrevCancelButtonClick: TNotifyEvent;
begin
ArcProgressPage :=
CreateOutputProgressPage('Decompression', 'Decompressing archive...');
ArcProgressPage.SetProgress(0, 100);
ArcProgressPage.Show;
try
WizardForm.CancelButton.Visible := True;
WizardForm.CancelButton.Enabled := True;
PrevCancelButtonClick := WizardForm.CancelButton.OnClick;
WizardForm.CancelButton.OnClick := #UnpackCancelButtonClick;
try
AddArchive(ExpandConstant('{src}\test1.arc'));
AddArchive(ExpandConstant('{src}\test2.arc'));
Log('Arc extraction starting');
UnPackArchives(ExpandConstant('{app}'));
except
MsgBox(GetExceptionMessage(), mbError, MB_OK);
end;
finally
Log('Arc extraction done');
ArcProgressPage.Hide;
WizardForm.CancelButton.OnClick := PrevCancelButtonClick;
end;
end;
procedure CurStepChanged(CurStep: TSetupStep);
begin
if CurStep = ssPostInstall then
begin
ExtractArc;
end;
end;
For CreateCallback function, you need Inno Setup 6. If you are stuck with Inno Setup 5, you can use WrapCallback function from InnoTools InnoCallback library.

Related

Multithreaded File Preview (Lazarus + WinAPI)

Hello all,
i am having problems getting the file preview (the one shown on the right side in the Windows Explorer window) for a certain file.
So far fetching the file preview works fine, but it takes a long time (between 0.5 and 2 seconds). Thus i do not want it to be executed in the main thread (as this would interrupt the program gui).
I tried to execute the file preview extraction in a worker thread, but this yields a SIGSEGV.
The call stack is also not really useful, it only shows that the exception is raised in ShellObjHelper in Line 141 (see source code below).
Source Code for main unit:
type
TThreadedImageInfo = record
fileName: String;
width: integer;
height: integer;
icon: TIcon;
image: TImage;
bmp: TBitmap;
infoOut: String;
memo: TMemo;
end;
PThreadedImageInfo = ^TThreadedImageInfo;
procedure loadThumbnailImageFromFile(aData: Pointer);
var
XtractImage: IExtractImage;
ColorDepth: integer;
Flags: DWORD;
RT: IRunnableTask;
FileName: string;
pThreadInfo: PThreadedImageInfo;
begin
pThreadInfo := PThreadedImageInfo(aData);
if assigned(pThreadInfo) then begin
FileName := pThreadInfo^.fileName;
ColorDepth := 32;
Flags := IEIFLAG_ASPECT or IEIFLAG_QUALITY or IEIFLAG_ORIGSIZE; // = 580
if FileExists(FileName) then begin
if GetExtractImageItfPtr(FileName, XTractImage) then begin
if ExtractImageGetFileThumbnail(XtractImage, pthreadinfo^.Image.Width,
pthreadinfo^.Image.Height, ColorDepth, Flags, RT, pthreadinfo^.Bmp) then begin
if (Flags and IEIFLAG_CACHE) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'Extractor does not cache the thumbnail.' + #13;
if (Flags and IEIFLAG_GLEAM) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'The image has a gleam.' + #13;
if (Flags and IEIFLAG_NOSTAMP) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'Extractor does not want an icon stamp on the thumbnail.' + #13;
if (Flags and IEIFLAG_NOBORDER) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'Extractor does not want an a border around the thumbnail.' + #13;
end else if GetFileLargeIcon(FileName, pThreadInfo^.icon) then begin
pThreadInfo^.infoOut := 'Thumbnail is not available. Default icon displayed.';
end;
end else begin
pThreadInfo^.infoOut := 'Error loading IExtractImage.';
end;
end else begin
pThreadInfo^.infoOut := 'Error: File does not exist.';
end;
end;
end;
procedure threadDone(Sender: TObject; aData: Pointer);
var
pThreadInfo: PThreadedImageInfo;
begin
pthreadInfo := PThreadedImageInfo(aData);
if assigned(pThreadInfo) then begin
if assigned(pthreadInfo^.Bmp) then begin
pthreadinfo^.Image.Picture.Assign(pthreadInfo^.Bmp);
end else if assigned(pthreadInfo^.icon) then begin
pthreadinfo^.Image.Picture.Assign(pthreadInfo^.icon);
end else begin
pThreadInfo^.Image.Picture.Assign(nil);
end;
if assigned(pThreadInfo^.memo) then
pThreadInfo^.memo.Lines.Text := pThreadInfo^.infoOut;
if assigned(pthreadInfo^.icon) then
pthreadInfo^.icon.free();
if assigned(pthreadInfo^.bmp) then
pthreadInfo^.bmp.free();
end;
dispose(pthreadinfo);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
pThreadInfo: PThreadedImageInfo;
begin
new(pThreadInfo);
pThreadInfo^.fileName := Edit1.Text;
pThreadInfo^.image := Image1;
pThreadInfo^.memo := Memo1;
pThreadInfo^.icon := nil;
pThreadInfo^.bmp := nil;
pThreadInfo^.infoOut := '';
// use worker thread:
//TThread.ExecuteInThread(#loadThumbnailImageFromFile, pThreadInfo, #threadDone);
// use main thread:
loadThumbnailImageFromFile(pThreadInfo);
threadDone(nil, pThreadInfo);
end;
Source code for helper unit:
unit ShellObjHelper;
{$MODE objfpc}{$H+}
{$IFDEF VER100}{$DEFINE DELPHI3}{$ENDIF}
interface
uses
Windows, ShlObj, ActiveX, ShellAPI, Graphics, SysUtils, ComObj;
type
{ from ShlObjIdl.h }
IExtractImage = interface
['{BB2E617C-0920-11D1-9A0B-00C04FC2D6C1}']
function GetLocation(Buffer: PWideChar; BufferSize: DWORD; var Priority: DWORD; var Size: TSize;
ColorDepth: DWORD; var Flags: DWORD): HResult; stdcall;
function Extract(var BitmapHandle: HBITMAP): HResult; stdcall;
end;
IRunnableTask = interface
['{85788D00-6807-11D0-B810-00C04FD706EC}']
function Run: HResult; stdcall;
function Kill(fWait: BOOL): HResult; stdcall;
function Suspend: HResult; stdcall;
function Resume: HResult; stdcall;
function IsRunning: Longint; stdcall;
end;
const
{ from ShlObjIdl.h }
ITSAT_MAX_PRIORITY = 2;
ITSAT_MIN_PRIORITY = 1;
ITSAT_DEFAULT_PRIORITY = 0;
IEI_PRIORITY_MAX = ITSAT_MAX_PRIORITY;
IEI_PRIORITY_MIN = ITSAT_MIN_PRIORITY;
IEIT_PRIORITY_NORMAL = ITSAT_DEFAULT_PRIORITY;
IEIFLAG_ASYNC = $001; // ask the extractor if it supports ASYNC extract (free threaded)
IEIFLAG_CACHE = $002; // returned from the extractor if it does NOT cache the thumbnail
IEIFLAG_ASPECT = $004; // passed to the extractor to beg it to render to the aspect ratio of the supplied rect
IEIFLAG_OFFLINE = $008; // if the extractor shouldn't hit the net to get any content needs for the rendering
IEIFLAG_GLEAM = $010; // does the image have a gleam? this will be returned if it does
IEIFLAG_SCREEN = $020; // render as if for the screen (this is exlusive with IEIFLAG_ASPECT)
IEIFLAG_ORIGSIZE = $040; // render to the approx size passed, but crop if neccessary
IEIFLAG_NOSTAMP = $080; // returned from the extractor if it does NOT want an icon stamp on the thumbnail
IEIFLAG_NOBORDER = $100; // returned from the extractor if it does NOT want an a border around the thumbnail
IEIFLAG_QUALITY = $200; // passed to the Extract method to indicate that a slower, higher quality image is desired,
// re-compute the thumbnail
// IShellFolder methods helper
procedure ShellFolderBindToObject(const ShellFolder: IShellFolder; PIDL: PItemIDList; const riid: TGUID; out pv);
function ShellFolderGetUIObjectOf(const ShellFolder: IShellFolder; cidl: DWORD; var PIDL: PItemIDList;
riid: TGUID; out pv): Boolean;
procedure ShellFolderParseDisplayName(const ShellFolder: IShellFolder; const DisplayName: string; out PIDL: PItemIDList);
function GetExtractImageItfPtr(const FileName: string; out XtractImage: IExtractImage): Boolean;
function GetFileLargeIcon(const FileName: string; out LargeIcon: TIcon): Boolean;
function ExtractImageGetFileThumbnail(const XtractImage: IExtractImage; ImgWidth, ImgHeight, ImgColorDepth: Integer;
var Flags: DWORD; out RunnableTask: IRunnableTask; out Bmp: TBitmap): Boolean;
procedure GetShellFolderItfPtr(const FolderName: string; Malloc: IMalloc; out TargetFolder: IShellFolder);
implementation
procedure ShellFolderBindToObject(const ShellFolder: IShellFolder; PIDL: PItemIDList; const riid: TGUID; out pv);
begin
OleCheck(ShellFolder.BindToObject(PIDL, nil, riid, {$IFDEF DELPHI3}Pointer(pv){$ELSE}pv{$ENDIF}));
end;
function ShellFolderGetUIObjectOf(const ShellFolder: IShellFolder; cidl: DWORD; var PIDL: PItemIDList;
riid: TGUID; out pv): Boolean;
begin
Result := NOERROR = ShellFolder.GetUIObjectOf(0, cidl, PIDL, riid, nil, {$IFDEF DELPHI3}Pointer(pv){$ELSE}pv{$ENDIF});
end;
procedure ShellFolderParseDisplayName(const ShellFolder: IShellFolder; const DisplayName: string; out PIDL: PItemIDList);
var
Attributes, Eaten: DWORD;
begin
OleCheck(ShellFolder.ParseDisplayName(0, nil, PWideChar(WideString(DisplayName)), Eaten, PIDL, Attributes));
end;
function GetExtractImageItfPtr(const FileName: string; out XtractImage: IExtractImage): Boolean;
var
TargetFolder: IShellFolder;
FilePath: string;
ItemIDList: PItemIDList;
Malloc: IMalloc;
begin
FilePath := ExcludeTrailingBackslash(ExtractFilePath(FileName));
OleCheck(SHGetMalloc(Malloc));
GetShellFolderItfPtr(FilePath, Malloc, TargetFolder);
ShellFolderParseDisplayName(TargetFolder, ExtractFileName(FileName), ItemIDList);
try
Result := ShellFolderGetUIObjectOf(TargetFolder, 1, ItemIDList, IExtractImage, XtractImage);
finally
Malloc.Free(ItemIDList);
end;
end;
function GetFileLargeIcon(const FileName: string; out LargeIcon: TIcon): Boolean;
var
SFI: TSHFileInfo;
begin
result := SHGetFileInfo(PChar(FileName), FILE_ATTRIBUTE_ARCHIVE, SFI, sizeof(SFI), SHGFI_ICON or SHGFI_LARGEICON) <> 0;
if result then begin
LargeIcon := TIcon.Create;
LargeIcon.Handle := SFI.hIcon;
end;
end;
function ExtractImageGetFileThumbnail(const XtractImage: IExtractImage; ImgWidth, ImgHeight, ImgColorDepth: Integer;
var Flags: DWORD; out RunnableTask: IRunnableTask; out Bmp: TBitmap): Boolean;
var
Size: TSize;
Buf: array[0..MAX_PATH] of WideChar;
BmpHandle: HBITMAP;
Priority: DWORD;
GetLocationRes: HRESULT;
procedure FreeAndNilBitmap;
begin
{$IFNDEF DELPHI3}
FreeAndNil(Bmp);
{$ELSE}
Bmp.Free;
Bmp := nil;
{$ENDIF}
end;
begin
Result := False;
RunnableTask := nil;
Size.cx := ImgWidth;
Size.cy := ImgHeight;
Priority := IEIT_PRIORITY_NORMAL;
Flags := Flags or IEIFLAG_ASYNC;
////////////////////////// EXCEPTION HERE, but only when multithreading /////////////////////////////////////////////////////
GetLocationRes := XtractImage.GetLocation(Buf, sizeof(Buf), Priority, Size, ImgColorDepth, Flags);
if (GetLocationRes = NOERROR) or (GetLocationRes = E_PENDING) then begin
if GetLocationRes = E_PENDING then begin
{ if QI for IRunnableTask succeed, we can use RunnableTask
interface pointer later to kill running extraction process.
We could spawn a new thread here to extract image. }
if S_OK <> XtractImage.QueryInterface(IRunnableTask, RunnableTask) then
RunnableTask := nil;
end;
Bmp := TBitmap.Create;
try
// This could consume a long time.
// If RunnableTask is available then calling Kill() method will immediately abort the process.
OleCheck(XtractImage.Extract(BmpHandle));
Bmp.Handle := BmpHandle;
Result := True;
except
on E: EOleSysError do begin
//-------------
OutputDebugString(PChar(string(E.ClassName) + ': ' + E.Message));
//-------------
FreeAndNilBitmap;
Result := False;
end else begin
FreeAndNilBitmap;
raise;
end;
end; { try/except }
end;
end;
procedure GetShellFolderItfPtr(const FolderName: string; Malloc: IMalloc; out TargetFolder: IShellFolder);
var
DesktopFolder: IShellFolder;
ItemIDList: PItemIDList;
begin
OleCheck(SHGetDesktopFolder(DesktopFolder));
ShellFolderParseDisplayName(DesktopFolder, FolderName, ItemIDList);
try
ShellFolderBindToObject(DesktopFolder, ItemIDList, IShellFolder, TargetFolder);
finally
Malloc.Free(ItemIDList);
end;
end;
end.
The actual question(s):
Why is the image extraction working without multithreading, but failing when using a worker thread?
How can i make this work?
I already started studying this post for another solution, but i am not yet sure how to do this.
Useful Informations:
Source for helper unit code: How to retrieve the file previews used by windows explorer in Windows vista and seven?
Multithreading example: https://lazarus-ccr.sourceforge.io/docs/rtl/classes/tthread.executeinthread.html
Activating PDF preview: open Adobe Acrobat Reader -> Edit -> Preferences -> General -> check "Enable PDF thumbnail previews"
I am using Lazarus v2.0.10 r63526 on Windows 10 Pro 64 bit.
Thanks to the comment from #IInspectable, that's the hint i needed.
Solution:
Add CoInitialize before calling GetExtractImageItfPtr and add CoUninitialize after receiving the file preview, but still within the worker thread.
Ensure that CoUninitialize is called even if exceptions occur by using try and finally`.
Working source code for main unit with worker thread:
type
TThreadedImageInfo = record
fileName: String;
width: integer;
height: integer;
icon: TIcon;
image: TImage;
bmp: TBitmap;
infoOut: String;
memo: TMemo;
end;
PThreadedImageInfo = ^TThreadedImageInfo;
procedure loadThumbnailImageFromFile(aData: Pointer);
var
XtractImage: IExtractImage;
ColorDepth: integer;
Flags: DWORD;
RT: IRunnableTask;
FileName: string;
pThreadInfo: PThreadedImageInfo;
begin
pThreadInfo := PThreadedImageInfo(aData);
if assigned(pThreadInfo) then begin
FileName := pThreadInfo^.fileName;
ColorDepth := 32;
Flags := IEIFLAG_ASPECT or IEIFLAG_QUALITY or IEIFLAG_ORIGSIZE; // = 580
if FileExists(FileName) then begin
CoInitialize(nil);
try
if GetExtractImageItfPtr(FileName, XTractImage) then begin
if ExtractImageGetFileThumbnail(XtractImage, pthreadinfo^.Image.Width,
pthreadinfo^.Image.Height, ColorDepth, Flags, RT, pthreadinfo^.Bmp) then begin
if (Flags and IEIFLAG_CACHE) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'Extractor does not cache the thumbnail.' + #13;
if (Flags and IEIFLAG_GLEAM) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'The image has a gleam.' + #13;
if (Flags and IEIFLAG_NOSTAMP) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'Extractor does not want an icon stamp on the thumbnail.' + #13;
if (Flags and IEIFLAG_NOBORDER) <> 0 then
pThreadInfo^.infoOut := pThreadInfo^.infoOut + 'Extractor does not want an a border around the thumbnail.' + #13;
end else if GetFileLargeIcon(FileName, pThreadInfo^.icon) then begin
pThreadInfo^.infoOut := 'Thumbnail is not available. Default icon displayed.';
end;
end else begin
pThreadInfo^.infoOut := 'Error loading IExtractImage.';
end;
finally
CoUninitialize;
end;
end else begin
pThreadInfo^.infoOut := 'Error: File does not exist.';
end;
end;
end;
procedure threadDone(Sender: TObject; aData: Pointer);
var
pThreadInfo: PThreadedImageInfo;
begin
pthreadInfo := PThreadedImageInfo(aData);
if assigned(pThreadInfo) then begin
if assigned(pthreadInfo^.Bmp) then begin
pthreadinfo^.Image.Picture.Assign(pthreadInfo^.Bmp);
end else if assigned(pthreadInfo^.icon) then begin
pthreadinfo^.Image.Picture.Assign(pthreadInfo^.icon);
end else begin
pThreadInfo^.Image.Picture.Assign(nil);
end;
if assigned(pThreadInfo^.memo) then
pThreadInfo^.memo.Lines.Text := pThreadInfo^.infoOut;
if assigned(pthreadInfo^.icon) then
pthreadInfo^.icon.free();
if assigned(pthreadInfo^.bmp) then
pthreadInfo^.bmp.free();
end;
dispose(pthreadinfo);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
pThreadInfo: PThreadedImageInfo;
begin
new(pThreadInfo);
pThreadInfo^.fileName := Edit1.Text;
pThreadInfo^.image := Image1;
pThreadInfo^.memo := Memo1;
pThreadInfo^.icon := nil;
pThreadInfo^.bmp := nil;
pThreadInfo^.infoOut := '';
TThread.ExecuteInThread(#loadThumbnailImageFromFile, pThreadInfo, #threadDone);
end;

How to send records containing strings between applications

So, I have a class that uses WM_COPYDATA to allow applications to communicate.
type
TMyRec = record
Name: string[255]; // I want just string
Age: integer;
Birthday: TDateTime;
end;
function TAppCommunication.SendRecord(const ARecordType: ShortString; const ARecordToSend: Pointer; ARecordSize: Integer): Boolean;
var
_Stream: TMemoryStream;
begin
_Stream := TMemoryStream.Create;
try
_Stream.WriteBuffer(ARecordType, 1 + Length(ARecordType));
_Stream.WriteBuffer(ARecordToSend^, ARecordSize);
_Stream.Position := 0;
Result := SendStreamData(_Stream, TCopyDataType.cdtRecord);
finally
FreeAndNil(_Stream);
end;
end;
function TAppCommunication.SendStreamData(const AStream: TMemoryStream;
const ADataType: TCopyDataType): Boolean;
var
_CopyDataStruct: TCopyDataStruct;
begin
Result := False;
if AStream.Size = 0 then
Exit;
_CopyDataStruct.dwData := integer(ADataType);
_CopyDataStruct.cbData := AStream.Size;
_CopyDataStruct.lpData := AStream.Memory;
Result := SendData(_CopyDataStruct);
end;
function TAppCommunication.SendData(const ADataToSend: TCopyDataStruct)
: Boolean;
var
_SendResponse: integer;
_ReceiverHandle: THandle;
begin
Result := False;
_ReceiverHandle := GetRemoteReceiverHandle;
if (_ReceiverHandle = 0) then
Exit;
_SendResponse := SendMessage(_ReceiverHandle, WM_COPYDATA,
WPARAM(FLocalReceiverForm.Handle), LPARAM(#ADataToSend));
Result := _SendResponse <> 0;
end;
Sender application:
procedure TSenderMainForm.BitBtn1Click(Sender: TObject);
var
_AppCommunication: TAppCommunication;
_ms: TMemoryStream;
_Rec: TMyRec;
_Record: TAttrData;
begin
_AppCommunication := TAppCommunication.Create('LocalReceiverName', OnAppMessageReceived);
_ms := TMemoryStream.Create;
try
_AppCommunication.SetRemoteReceiverName('LocalReceiverNameServer');
_AppCommunication.SendString('ąčęėįšųūž123');
_AppCommunication.SendInteger(998);
_AppCommunication.SendDouble(0.95);
_Rec.Name := 'Edijs';
_Rec.Age := 29;
_Rec.Birthday := EncodeDate(1988, 10, 06);
_Record.Len := 1988;
_AppCommunication.SendRecord(TTypeInfo(System.TypeInfo(TMyRec)^).Name, #_Rec, SizeOf(_Rec));
finally
FreeAndNil(_ms);
FreeAndNil(_AppCommunication);
end;
end;
Receiver app:
procedure TReceiverMainForm.OnAppMessageReceived(const ASender
: TPair<HWND, string>; const AReceivedData: TCopyDataStruct;
var AResult: integer);
var
_MyRec: TMyRec;
_RecType: ShortString;
_RecData: Pointer;
begin
...
else
begin
if (AReceivedData.dwData) = Ord(TCopyDataType.cdtRecord) then
begin
_RecType := PShortString(AReceivedData.lpData)^;
_RecData := PByte(AReceivedData.lpData)+1+Length(_RecType);
if (_RecType = TTypeInfo(System.TypeInfo(TMyRec)^).Name) then
begin
_MyRec := TMyRec(_RecData^);
ShowMessage(_MyRec.Name + ', Age: ' + IntToStr(_MyRec.Age) + ', birthday: ' +
DateToStr(_MyRec.Birthday));
end;
end;
AResult := -1;
end;
end;
The problem is that crash occur when I change Name: string[255]; to Name: string; in TMyRec. How do I overcome this? I do not want to edit all my records to change string to something else and I want to have one function to send all kind of records (as far as my idea goes none of them will contain objects).
EDITED:
Used answer provided by Remy and made some tweaks so I would by able to send any kind of record using only one SendRecord function:
function TAppCommunication.SendRecord(const ARecordToSend, ARecordTypInfo: Pointer): Boolean;
var
_Stream: TMemoryStream;
_RType: TRTTIType;
_RFields: TArray<TRttiField>;
i: Integer;
begin
_Stream := TMemoryStream.Create;
try
_RType := TRTTIContext.Create.GetType(ARecordTypInfo);
_Stream.WriteString(_RType.ToString);
_RFields := _RType.GetFields;
for i := 0 to High(_RFields) do
begin
if _RFields[i].FieldType.TypeKind = TTypeKind.tkUString then
_Stream.WriteString(_RFields[i].GetValue(ARecordToSend).ToString)
else if _RFields[i].FieldType.TypeKind = TTypeKind.tkInteger then
_Stream.WriteInteger(_RFields[i].GetValue(ARecordToSend).AsType<integer>)
else if _RFields[i].FieldType.TypeKind = TTypeKind.tkFloat then
_Stream.WriteDouble(_RFields[i].GetValue(ARecordToSend).AsType<Double>)
end;
_Stream.Position := 0;
Result := SendStreamData(_Stream, TCopyDataType.cdtRecord);
finally
FreeAndNil(_Stream);
end;
end;
Sender:
_AppCommunication.SendRecord(#_Rec, System.TypeInfo(TMyRec));
A ShortString has a fixed size of 256 bytes max (1 byte length + up to 255 AnsiChars), so it is easy to embed in records and send as-is.
A String, on the other hand, is a pointer to dynamically allocated memory for an array of Chars. So, it requires a little more work to serialize back and forth.
To do what you are asking, you can't simply replace ShortString with String without also changing everything else in between to account for that difference.
You already have the basic framework to send variable-length strings (send the length before sending the data), so you can expand on that to handle string values, eg:
type
TMyRec = record
Name: string;
Age: integer;
Birthday: TDateTime;
end;
TStreamHelper = class helper for TStream
public
function ReadInteger: Integer;
function ReadDouble: Double;
function ReadString: String;
...
procedure WriteInteger(Value: Integer);
procedure WriteDouble(Strm: Value: Double);
procedure WriteString(const Value: String);
end;
function TStreamHelper.ReadInteger: Integer;
begin
Self.ReadBuffer(Result, SizeOf(Integer));
end;
function TStreamHelper.ReadDouble: Double;
begin
Self.ReadBuffer(Result, SizeOf(Double));
end;
function TStreamHelper.ReadString: String;
var
_Bytes: TBytes;
_Len: Integer;
begin
_Len := ReadInteger;
SetLength(_Bytes, _Len);
Self.ReadBuffer(PByte(_Bytes)^, _Len);
Result := TEncoding.UTF8.GetString(_Bytes);
end;
...
procedure TStreamHelper.WriteInteger(Value: Integer);
begin
Self.WriteBuffer(Value, SizeOf(Value));
end;
procedure TStreamHelper.WriteDouble(Value: Double);
begin
Self.WriteBuffer(Value, SizeOf(Value));
end;
procedure TStreamHelper.WriteString(const Value: String);
var
_Bytes: TBytes;
_Len: Integer;
begin
_Bytes := TEncoding.UTF8.GetBytes(Value);
_Len := Length(_Bytes);
WriteInteger(_Len);
Self.WriteBuffer(PByte(_Bytes)^, _Len);
end;
function TAppCommunication.SendRecord(const ARecord: TMyRec): Boolean;
var
_Stream: TMemoryStream;
begin
_Stream := TMemoryStream.Create;
try
_Stream.WriteString('TMyRec');
_Stream.WriteString(ARecord.Name);
_Stream.WriteInteger(ARecord.Age);
_Stream.WriteDouble(ARecord.Birthday);
_Stream.Position := 0;
Result := SendStreamData(_Stream, TCopyDataType.cdtRecord);
finally
FreeAndNil(_Stream);
end;
end;
// more overloads of SendRecord()
// for other kinds of records as needed...
procedure TSenderMainForm.BitBtn1Click(Sender: TObject);
var
...
_Rec: TMyRec;
begin
...
_Rec.Name := 'Edijs';
_Rec.Age := 29;
_Rec.Birthday := EncodeDate(1988, 10, 06);
_AppCommunication.SendRecord(_Rec);
...
end;
type
TReadOnlyMemoryStream = class(TCustomMemoryStream)
public
constructor Create(APtr: Pointer; ASize: NativeInt);
function Write(const Buffer; Count: Longint): Longint; override;
end;
constructor TReadOnlyMemoryStream.Create(APtr: Pointer; ASize: NativeInt);
begin
inherited Create;
SetPointer(APtr, ASize);
end;
function TReadOnlyMemoryStream.Write(const Buffer; Count: Longint): Longint;
begin
Result := 0;
end;
procedure TReceiverMainForm.OnAppMessageReceived(const ASender : TPair<HWND, string>; const AReceivedData: TCopyDataStruct; var AResult: integer);
var
...
_Stream: TReadOnlyMemoryStream;
_MyRec: TMyRec;
_RecType: String;
begin
...
else
begin
if (AReceivedData.dwData = Ord(TCopyDataType.cdtRecord)) then
begin
_Stream := TReadOnlyMemoryStream(AReceivedData.lpData, AReceivedData.cbData);
try
_RecType := _Stream.ReadString;
if (_RecType = 'TMyRec') then
begin
_MyRec.Name := _Stream.ReadString;
_MyRec.Age := _Stream.ReadInteger;
_MyRec.Birthday := _Stream.ReadDouble;
ShowMessage(_MyRec.Name + ', Age: ' + IntToStr(_MyRec.Age) + ', birthday: ' + DateToStr(_MyRec.Birthday));
end;
finally
_Stream.Free;
end;
end;
AResult := -1;
end;
end;

Inno Setup - How to add cancel button to decompressing page?

I am using this code: How to add .arc decompression to Inno Setup? (answer of Martin Prikryl). I want to add a cancel button at decompressing page and active this page for others functions (when the decompression is active, this page is inactive and, for example, i can not press on/off button of my music implementation).
How to add a cancel button to decompression page? and how to active this page for others functions?
I have reimplemented the solution from How to add .arc decompression to Inno Setup? using unarc.dll (from FreeArc+InnoSetup package ISFreeArcExtract v.4.0.rar).
It greatly simplifies the code and also makes it easier to add the ability to cancel the decompression.
#define ArcArchive "test.arc"
[Files]
Source: unarc.dll; Flags: dontcopy
[Code]
const
ArcCancelCode = -10;
function FreeArcExtract(
Callback: LongWord;
Cmd1, Cmd2, Cmd3, Cmd4, Cmd5, Cmd6, Cmd7, Cmd8, Cmd9, Cmd10: PAnsiChar
): Integer;
external 'FreeArcExtract#files:unarc.dll cdecl';
const
CP_UTF8 = 65001;
function WideCharToMultiByte(CodePage: UINT; dwFlags: DWORD;
lpWideCharStr: string; cchWideChar: Integer; lpMultiByteStr: AnsiString;
cchMultiByte: Integer; lpDefaultCharFake: Integer;
lpUsedDefaultCharFake: Integer): Integer;
external 'WideCharToMultiByte#kernel32.dll stdcall';
function GetStringAsUtf8(S: string): AnsiString;
var
Len: Integer;
begin
Len := WideCharToMultiByte(CP_UTF8, 0, S, Length(S), Result, 0, 0, 0);
SetLength(Result, Len);
WideCharToMultiByte(CP_UTF8, 0, S, Length(S), Result, Len, 0, 0);
end;
var
ArcTotalSize: Integer;
ArcExtracted: Integer;
ArcCancel: Boolean;
ArcProgressPage: TOutputProgressWizardPage;
function FreeArcCallback(
AWhat: PAnsiChar; Int1, Int2: Integer; Str: PAnsiChar): Integer;
var
What: string;
begin
What := AWhat;
if What = 'origsize' then
begin
ArcTotalSize := Int1;
Log(Format('Total size of files to be extracted is %d MB', [ArcTotalSize]));
end
else
if What = 'write' then
begin
if ArcTotalSize > 0 then
begin
ArcProgressPage.SetProgress(Int1, ArcTotalSize);
end;
ArcExtracted := Int1;
end
else
begin
// Just to pump message queue more often (particularly for 'read' callbacks),
// to get more smooth progress bar
if (ArcExtracted > 0) and (ArcTotalSize > 0) then
begin
ArcProgressPage.SetProgress(ArcExtracted, ArcTotalSize);
end;
end;
if ArcCancel then Result := ArcCancelCode
else Result := 0;
end;
function FreeArcCmd(
Cmd1, Cmd2, Cmd3, Cmd4, Cmd5, Cmd6, Cmd7, Cmd8, Cmd9, Cmd10: string): Integer;
begin
ArcCancel := False;
try
Result :=
FreeArcExtract(
CreateCallback(#FreeArcCallback),
GetStringAsUtf8(Cmd1), GetStringAsUtf8(Cmd2), GetStringAsUtf8(Cmd3),
GetStringAsUtf8(Cmd4), GetStringAsUtf8(Cmd5), GetStringAsUtf8(Cmd6),
GetStringAsUtf8(Cmd7), GetStringAsUtf8(Cmd8), GetStringAsUtf8(Cmd9),
GetStringAsUtf8(Cmd10));
Log(Format('Arc command "%s" result %d', [Cmd1, Result]));
except
Result := -63;
end;
end;
function UnPackArchive(ArchivePath: string; DestPath: string): Integer;
begin
{ Find out length of files to be extracted - origsize }
Result := FreeArcCmd('l', '--', ArchivePath, '', '', '', '', '', '', '');
if Result = 0 then
begin
// Actually extract
Result :=
FreeArcCmd('x', '-o+', '-dp' + DestPath, '-w' + DestPath, '--', ArchivePath,
'', '', '', '');
end;
end;
procedure UnpackCancelButtonClick(Sender: TObject);
begin
ArcCancel := True;
end;
procedure ExtractArc;
var
ArcArchivePath: string;
UnpackResult: Integer;
PrevCancelButtonClick: TNotifyEvent;
Error: string;
begin
ArcProgressPage :=
CreateOutputProgressPage('Decompression', 'Decompressing archive...');
ArcProgressPage.SetProgress(0, 100);
ArcProgressPage.Show;
try
WizardForm.CancelButton.Visible := True;
WizardForm.CancelButton.Enabled := True;
PrevCancelButtonClick := WizardForm.CancelButton.OnClick;
WizardForm.CancelButton.OnClick := #UnpackCancelButtonClick;
ArcArchivePath := ExpandConstant('{src}\{#ArcArchive}');
Log(Format('Arc extraction starting - %s', [ArcArchivePath]));
ArcExtracted := 0;
UnpackResult := UnPackArchive(ArcArchivePath, ExpandConstant('{app}'));
if UnpackResult <> 0 then
begin
if ArcCancel then
begin
Error := 'Extraction cancelled';
end
else
begin
Error := Format('Extraction failed with code %d', [UnpackResult]);
end;
MsgBox(Error, mbError, MB_OK);
end;
finally
Log('Arc extraction cleanup');
ArcProgressPage.Hide;
WizardForm.CancelButton.OnClick := PrevCancelButtonClick;
end;
end;
procedure CurStepChanged(CurStep: TSetupStep);
begin
if CurStep = ssPostInstall then
begin
ExtractArc;
end;
end;
For CreateCallback function, you need Inno Setup 6. If you are stuck with Inno Setup 5, you can use WrapCallback function from InnoTools InnoCallback library.
The code extracts a separate .arc file. If you want to embed the archive to the installer, you can use
[Files]
Source: {#ArcArchive}; DestDir: "{tmp}"; Flags: nocompression deleteafterinstall
And extract the archive from the {tmp}:
ArcArchivePath := ExpandConstant('{tmp}\{#ArcArchive}');
Note that the unarc.dll from ISFreeArcExtract v.4.0.rar does not seem to support password protected archives. The version from ISFreeArcExtract v.4.2.rar does, but I'm not aware of trustworthy download link.
If you want to extract multiple archives, see Inno Setup - How to add multiple arc files to decompress?
All you need is this
http://fileforums.com/showthread.php?t=96619
This program have the latest compatibility with inno setup and also supports Password based file with multiple extensions.

Inno Setup torrent download implementation

I am currently using Inno Download Plugin to download files for my installer, the biggest problem with this is that it fails to download the file correctly. Because of many reasons like bad connection. I would like to add an alternative method to download files, so the user may chose if he want regular way, or a torrent way. I know that I can use aria2c.exe app. Can someone help me with implementing it to the code of inno setup?
What I need is to download a 7z file using torrent (aria2.exe) and then unpack the contents to defined folder in {app} location.
Good code example is probably all I need.
Just run the aria2c, redirect its output to a file and poll the file contents for progress of the download.
It's actually very similar to my solution for this answer:
Make Inno Setup Installer report its installation progress status to master installer
#define TorrentMagnet "magnet:..."
[Files]
Source: aria2c.exe; Flags: dontcopy
[Code]
function BufferToAnsi(const Buffer: string): AnsiString;
var
W: Word;
I: Integer;
begin
SetLength(Result, Length(Buffer) * 2);
for I := 1 to Length(Buffer) do
begin
W := Ord(Buffer[I]);
Result[(I * 2)] := Chr(W shr 8); { high byte }
Result[(I * 2) - 1] := Chr(Byte(W)); { low byte }
end;
end;
function SetTimer(
Wnd: LongWord; IDEvent, Elapse: LongWord; TimerFunc: LongWord): LongWord;
external 'SetTimer#user32.dll stdcall';
function KillTimer(hWnd: LongWord; uIDEvent: LongWord): BOOL;
external 'KillTimer#user32.dll stdcall';
var
ProgressPage: TOutputProgressWizardPage;
ProgressFileName: string;
procedure UpdateProgressProc(
H: LongWord; Msg: LongWord; Event: LongWord; Time: LongWord);
var
S: AnsiString;
I: Integer;
L: Integer;
P: Integer;
Max: Integer;
Progress: string;
Buffer: string;
Stream: TFileStream;
Transferred: string;
Percent: Integer;
Found: Boolean;
begin
Found := False;
try
{ Need shared read as the output file is locked for writting, }
{ so we cannot use LoadStringFromFile }
Stream := TFileStream.Create(ProgressFileName, fmOpenRead or fmShareDenyNone);
try
L := Stream.Size;
Max := 100*2014;
if L > Max then
begin
Stream.Position := L - Max;
L := Max;
end;
SetLength(Buffer, (L div 2) + (L mod 2));
Stream.ReadBuffer(Buffer, L);
S := BufferToAnsi(Buffer);
finally
Stream.Free;
end;
if S = '' then
begin
Log(Format('Progress file %s is empty', [ProgressFileName]));
end;
except
Log(Format('Failed to read progress from file %s', [ProgressFileName]));
end;
if S <> '' then
begin
P := Pos('[#', S);
if P = 0 then
begin
Log('Not found any progress line');
end
else
begin
repeat
Delete(S, 1, P - 1);
P := Pos(']', S);
Progress := Copy(S, 2, P - 2);
Delete(S, 1, P);
P := Pos('[#', S);
until (P = 0);
Log(Format('Found progress line: %s', [Progress]));
P := Pos(' ', Progress);
if P > 0 then
begin
Log('A');
Delete(Progress, 1, P);
P := Pos('(', Progress);
if P > 0 then
begin
Log('b');
Transferred := Copy(Progress, 1, P - 1);
Delete(Progress, 1, P);
P := Pos('%)', Progress);
if P > 0 then
begin
Log('c');
Percent := StrToIntDef(Copy(Progress, 1, P - 1), -1);
if Percent >= 0 then
begin
Log(Format('Transferred: %s, Percent: %d', [Transferred, Percent]));
ProgressPage.SetProgress(Percent, 100);
ProgressPage.SetText(Format('Transferred: %s', [Transferred]), '');
Found := True;
end;
end;
end;
end;
end;
end;
if not Found then
begin
Log('No new data found');
{ no new progress data, at least pump the message queue }
ProgressPage.SetProgress(ProgressPage.ProgressBar.Position, 100);
end;
end;
function PrepareToInstall(var NeedsRestart: Boolean): String;
var
TorrentDownloaderPath: string;
TempPath: string;
CommandLine: string;
Timer: LongWord;
InstallError: string;
ResultCode: Integer;
S: AnsiString;
begin
ExtractTemporaryFile('aria2c.exe');
ProgressPage :=
CreateOutputProgressPage('Torrent download', 'Downloading torrent...');
ProgressPage.SetProgress(0, 100);
ProgressPage.Show;
try
Timer := SetTimer(0, 0, 250, CreateCallback(#UpdateProgressProc));
TempPath := ExpandConstant('{tmp}');
TorrentDownloaderPath := TempPath + '\aria2c.exe';
ProgressFileName := ExpandConstant('{tmp}\progress.txt');
Log(Format('Expecting progress in %s', [ProgressFileName]));
CommandLine :=
Format('"%s" "%s" > "%s"', [
TorrentDownloaderPath, '{#TorrentMagnet}', ProgressFileName]);
Log(Format('Executing: %s', [CommandLine]));
CommandLine := Format('/C "%s"', [CommandLine]);
if not Exec(ExpandConstant('{cmd}'), CommandLine, TempPath, SW_HIDE,
ewWaitUntilTerminated, ResultCode) then
begin
Result := 'Cannot start torrent download';
end
else
if ResultCode <> 0 then
begin
LoadStringFromFile(ProgressFileName, S);
Result := Format('Torrent download failed with code %d', [ResultCode]);
Log(Result);
Log('Output: ' + S);
end;
finally
{ Clean up }
KillTimer(0, Timer);
ProgressPage.Hide;
DeleteFile(ProgressFileName);
end;
end;
For CreateCallback function, you need Inno Setup 6. If you are stuck with Inno Setup 5, you can use WrapCallback function from InnoTools InnoCallback library.
The BufferToAnsi and its use is based on:
Inno Setup LoadStringFromFile fails when file is open in another process

Inno Setup: Enlarge component page only with preview and description

I need help from you to merge two scripts found here to have preview image on a maximized components windows:
Add image into the components list - component description
Long descriptions on Inno Setup components
Edit: Thanks to Martin Prikryl. With his patience and his help, I successfully merge these two scripts.
Your preview image should have a resolution of 208x165 in .bmp
[Files]
...
Source: "1.bmp"; Flags: dontcopy
Source: "2.bmp"; Flags: dontcopy
Source: "3.bmp"; Flags: dontcopy
Source: "InnoCallback.dll"; Flags: dontcopy
[Code]
var
LastMouse: TPoint;
type
TTimerProc = procedure(H: LongWord; Msg: LongWord; IdEvent: LongWord; Time: LongWord);
function GetCursorPos(var lpPoint: TPoint): BOOL; external 'GetCursorPos#user32.dll stdcall';
function SetTimer(hWnd: longword; nIDEvent, uElapse: LongWord; lpTimerFunc: LongWord): LongWord; external 'SetTimer#user32.dll stdcall';
function ScreenToClient(hWnd: HWND; var lpPoint: TPoint): BOOL; external 'ScreenToClient#user32.dll stdcall';
function ClientToScreen(hWnd: HWND; var lpPoint: TPoint): BOOL; external 'ClientToScreen#user32.dll stdcall';
function ListBox_GetItemRect(const hWnd: HWND; const Msg: Integer; Index: LongInt; var Rect: TRect): LongInt; external 'SendMessageW#user32.dll stdcall';
const
LB_GETITEMRECT = $0198;
LB_GETTOPINDEX = $018E;
function WrapTimerProc(Callback: TTimerProc; ParamCount: Integer): LongWord; external 'wrapcallback#files:InnoCallback.dll stdcall';
function FindControl(Parent: TWinControl; P: TPoint): TControl;
var
Control: TControl;
WinControl: TWinControl;
I: Integer;
P2: TPoint;
begin
for I := 0 to Parent.ControlCount - 1 do
begin
Control := Parent.Controls[I];
if Control.Visible and
(Control.Left <= P.X) and (P.X < Control.Left + Control.Width) and
(Control.Top <= P.Y) and (P.Y < Control.Top + Control.Height) then
begin
if Control is TWinControl then
begin
P2 := P;
ClientToScreen(Parent.Handle, P2);
WinControl := TWinControl(Control);
ScreenToClient(WinControl.Handle, P2);
Result := FindControl(WinControl, P2);
if Result <> nil then Exit;
end;
Result := Control;
Exit;
end;
end;
Result := nil;
end;
function PointInRect(const Rect: TRect; const Point: TPoint): Boolean;
begin
Result := (Point.X >= Rect.Left) and (Point.X <= Rect.Right) and
(Point.Y >= Rect.Top) and (Point.Y <= Rect.Bottom);
end;
function ListBoxItemAtPos(ListBox: TCustomListBox; Pos: TPoint): Integer;
var
Count: Integer;
ItemRect: TRect;
begin
Result := SendMessage(ListBox.Handle, LB_GETTOPINDEX, 0, 0);
Count := ListBox.Items.Count;
while Result < Count do
begin
ListBox_GetItemRect(ListBox.Handle, LB_GETITEMRECT, Result, ItemRect);
if PointInRect(ItemRect, Pos) then Exit;
Inc(Result);
end;
Result := -1;
end;
var
CompLabel: TLabel;
CompImage: TBitmapImage;
LoadingImage: Boolean;
procedure HoverComponentChanged(Index: Integer);
var
Description: string;
Image: string;
ImagePath: string;
begin
case Index of
0: begin Description := 'Component 1'; Image := '1.bmp'; end;
1: begin Description := 'Component 2'; Image := '2.bmp'; end;
2: begin Description := 'Component 3'; Image := '3.bmp'; end;
else
Description := 'Move your mouse over a component to see its description.';
end;
CompLabel.Caption := Description;
if Image <> '' then
begin
// The ExtractTemporaryFile pumps the message queue, prevent recursion
if not LoadingImage then
begin
LoadingImage := True;
try
ImagePath := ExpandConstant('{tmp}\' + Image);
if not FileExists(ImagePath) then
begin
ExtractTemporaryFile(Image);
end;
CompImage.Bitmap.LoadFromFile(ImagePath);
finally
LoadingImage := False;
end;
end;
CompImage.Visible := True;
end
else
begin
CompImage.Visible := False;
end;
end;
procedure HoverTimerProc(H: LongWord; Msg: LongWord; IdEvent: LongWord; Time: LongWord);
var
P: TPoint;
Control: TControl;
Index: Integer;
begin
GetCursorPos(P);
if P <> LastMouse then // just optimization
begin
LastMouse := P;
ScreenToClient(WizardForm.Handle, P);
if (P.X < 0) or (P.Y < 0) or
(P.X > WizardForm.ClientWidth) or (P.Y > WizardForm.ClientHeight) then
begin
Control := nil;
end
else
begin
Control := FindControl(WizardForm, P);
end;
Index := -1;
if Control = WizardForm.ComponentsList then
begin
P := LastMouse;
ScreenToClient(WizardForm.ComponentsList.Handle, P);
Index := ListBoxItemAtPos(WizardForm.ComponentsList, P);
end;
HoverComponentChanged(Index);
end;
end;
type
TPositionStorage = array of Integer;
var
CompPageModified: Boolean;
CompPagePositions: TPositionStorage;
procedure SaveComponentsPage(out Storage: TPositionStorage);
begin
SetArrayLength(Storage, 10);
Storage[0] := WizardForm.Height;
Storage[1] := WizardForm.NextButton.Top;
Storage[2] := WizardForm.BackButton.Top;
Storage[3] := WizardForm.CancelButton.Top;
Storage[4] := WizardForm.ComponentsList.Height;
Storage[5] := WizardForm.OuterNotebook.Height;
Storage[6] := WizardForm.InnerNotebook.Height;
Storage[7] := WizardForm.Bevel.Top;
Storage[8] := WizardForm.BeveledLabel.Top;
Storage[9] := WizardForm.ComponentsDiskSpaceLabel.Top;
end;
procedure LoadComponentsPage(const Storage: TPositionStorage;
HeightOffset: Integer);
begin
if GetArrayLength(Storage) <> 10 then
RaiseException('Invalid storage array length.');
WizardForm.Height := Storage[0] + HeightOffset;
WizardForm.NextButton.Top := Storage[1] + HeightOffset;
WizardForm.BackButton.Top := Storage[2] + HeightOffset;
WizardForm.CancelButton.Top := Storage[3] + HeightOffset;
WizardForm.ComponentsList.Height := Storage[4] + ScaleY(150);
WizardForm.OuterNotebook.Height := Storage[5] + HeightOffset;
WizardForm.InnerNotebook.Height := Storage[6] + HeightOffset;
WizardForm.Bevel.Top := Storage[7] + HeightOffset;
WizardForm.BeveledLabel.Top := Storage[8] + HeightOffset;
WizardForm.ComponentsDiskSpaceLabel.Top := Storage[9] + HeightOffset;
end;
procedure InitializeWizard1();
var
HoverTimerCallback: LongWord;
begin
HoverTimerCallback := WrapTimerProc(#HoverTimerProc, 4);
SetTimer(0, 0, 50, HoverTimerCallback);
CompLabel := TLabel.Create(WizardForm);
CompLabel.Parent := WizardForm.SelectComponentsPage;
CompLabel.Left := WizardForm.ComponentsList.Left;
CompLabel.Width := WizardForm.ComponentsList.Width div 2;
CompLabel.Height := ScaleY(64);
CompLabel.Top := WizardForm.ComponentsList.Top + WizardForm.ComponentsList.Height - CompLabel.Height + ScaleY(150);
CompLabel.AutoSize := false;
CompLabel.WordWrap := True;
CompImage := TBitmapImage.Create(WizardForm);
CompImage.Parent := WizardForm.SelectComponentsPage;
CompImage.Top := CompLabel.Top;
CompImage.Width := CompImage.Width + ScaleX(128);
CompImage.Height := CompLabel.Height + ScaleX(128);
CompImage.Left := WizardForm.ComponentsList.Left + WizardForm.ComponentsList.Width - CompLabel.Width;
WizardForm.ComponentsList.Height := WizardForm.ComponentsList.Height - CompLabel.Height - ScaleY(8);
end;
procedure InitializeWizard2();
begin
CompPageModified := False;
end;
procedure CurPageChanged(CurPageID: Integer);
begin
if CurpageID = wpSelectComponents then
begin
SaveComponentsPage(CompPagePositions);
LoadComponentsPage(CompPagePositions, ScaleY(250));
CompPageModified := True;
end
else
if CompPageModified then
begin
LoadComponentsPage(CompPagePositions, 0);
CompPageModified := False;
end;
end;
procedure InitializeWizard();
begin
InitializeWizard1();
InitializeWizard2();
end;
Just copy both codes and merge the InitializeWizard implementations according to this guide:
Merging event function (InitializeWizard) implementations from different sources.
Though, actually, the InitializeWizard in the Larger “Select Components” page in Inno Setup is noop. You can skip that. And you do not need to merge anything.
The only other change you need to do, is not to enlarge the ComponentsList in the LoadComponentsPage.

Resources