ПРИВЕТСТВУЮ ФОРУМЧАНЕ!
есть пример от
El Sanchez (перетаскивание формы)
код
[Setup]
AppName=Test
AppVerName=Test
OutputBaseFilename=Test
OutputDir=userdocs:..\desktop
DefaultDirName=Test
Uninstallable=no
[code]
const
VK_LBUTTON = $0001;
WM_SETCURSOR = $0020;
WM_LBUTTONDOWN = $0201;
HTCLIENT = 1;
SWP_NOSIZE = 1;
SWP_NOZORDER = 4;
SWP_NOOWNERZORDER = $0200;
function SetWindowSubclass(hWnd: HWND; pfnSubclass: LongWord; uIdSubclass: UINT_PTR; dwRefData: DWORD_PTR): BOOL; external 'SetWindowSubclass@comctl32.dll stdcall';
function RemoveWindowSubclass(hWnd: HWND; pfnSubclass: LongWord; uIdSubclass: UINT_PTR): BOOL; external 'RemoveWindowSubclass@comctl32.dll stdcall';
function DefSubclassProc(hWnd: HWND; uMsg: UINT; wParam: UINT_PTR; lParam: INT_PTR): INT_PTR; external 'DefSubclassProc@comctl32.dll stdcall';
function GetCursorPos(out lpPoint: TPoint): BOOL; external 'GetCursorPos@user32.dll stdcall';
function GetWindowRect(hWnd: HWND; out lpRect: TRect): BOOL; external 'GetWindowRect@user32.dll stdcall';
function SetWindowPos(hWnd, hWndInsertAfter: HWND; X, Y, cx, cy: Integer; uFlags: UINT): BOOL; external 'SetWindowPos@user32.dll stdcall';
function GetAsyncKeyState(vKey: Integer): SmallInt; external 'GetAsyncKeyState@user32.dll stdcall';
function OffsetRect(var lprc: TRect; dx, dy: Integer): BOOL; external 'OffsetRect@user32.dll stdcall';
var
PWndProc: LongWord;
function WndProc(hWnd: HWND; uMsg: UINT; wParam: UINT_PTR; lParam: INT_PTR;
uIdSubclass: UINT_PTR; dwRefData: DWORD_PTR): INT_PTR;
var
LWindowRect: TRect;
LSavePt, LCurPt: TPoint;
begin
case uMsg of
WM_SETCURSOR:
begin
Result := DefSubclassProc(hWnd, uMsg, wParam, lParam);
if (lParam shr $10 = WM_LBUTTONDOWN) and
(lParam and $FFFF = HTCLIENT) then
begin
GetWindowRect(hWnd, LWindowRect);
GetCursorPos(LSavePt);
while (GetAsyncKeyState(VK_LBUTTON) <> 0) do
begin
GetCursorPos(LCurPt);
OffsetRect(LWindowRect, LCurPt.x - LSavePt.x, LCurPt.y - LSavePt.y);
SetWindowPos(hWnd, 0, LWindowRect.Left, LWindowRect.Top,
0, 0, SWP_NOOWNERZORDER or SWP_NOSIZE or SWP_NOZORDER);
LSavePt := LCurPt;
end;
end;
end;
else
Result := DefSubclassProc(hWnd, uMsg, wParam, lParam);
end;
end;
procedure SubclassWizardForm(const ARemove: Boolean);
begin
if PWndProc = 0 then
PWndProc := CreateCallback(@WndProc);
if not ARemove then
SetWindowSubclass(WizardForm.Handle, PWndProc, 0, 0)
else if PWndProc <> 0 then
RemoveWindowSubclass(WizardForm.Handle, PWndProc, 0);
end;
procedure InitializeWizard;
begin
SubclassWizardForm(False);
end;
procedure DeinitializeSetup;
begin
SubclassWizardForm(True);
end;
потом есть пример с интернета, который запрещает запуск двух и более копий инсталлятора одновременно
код
[Setup]
AppName=Test
AppVerName=Test
OutputBaseFilename=Test
OutputDir=userdocs:..\desktop
DefaultDirName=Test
Uninstallable=no
AppMutex=qwerty
[code]
function CreateMutex(lpMutexAttributes: Longint; bInitialOwner: BOOL; lpName: AnsiString): THandle; external 'CreateMutexA@kernel32.dll stdcall';
var
Mutex: THandle;
procedure SMutex; begin Mutex:= CreateMutex(0, False, ExpandConstant('{#SetupSetting("AppMutex")}')); end;
procedure InitializeWizard();
begin
SMutex;
end;
function InitializeSetup(): Boolean;
begin
Result:= not CheckForMutexes(ExpandConstant('{#SetupSetting("AppMutex")}'));
end;
после склейки получаем
код
[Setup]
AppName=Test
AppVerName=Test
OutputBaseFilename=Test
OutputDir=userdocs:..\desktop
DefaultDirName=Test
Uninstallable=no
AppMutex=qwerty
[code]
const
VK_LBUTTON = $0001;
WM_SETCURSOR = $0020;
WM_LBUTTONDOWN = $0201;
HTCLIENT = 1;
SWP_NOSIZE = 1;
SWP_NOZORDER = 4;
SWP_NOOWNERZORDER = $0200;
function SetWindowSubclass(hWnd: HWND; pfnSubclass: LongWord; uIdSubclass: UINT_PTR; dwRefData: DWORD_PTR): BOOL; external 'SetWindowSubclass@comctl32.dll stdcall';
function RemoveWindowSubclass(hWnd: HWND; pfnSubclass: LongWord; uIdSubclass: UINT_PTR): BOOL; external 'RemoveWindowSubclass@comctl32.dll stdcall';
function DefSubclassProc(hWnd: HWND; uMsg: UINT; wParam: UINT_PTR; lParam: INT_PTR): INT_PTR; external 'DefSubclassProc@comctl32.dll stdcall';
function GetCursorPos(out lpPoint: TPoint): BOOL; external 'GetCursorPos@user32.dll stdcall';
function GetWindowRect(hWnd: HWND; out lpRect: TRect): BOOL; external 'GetWindowRect@user32.dll stdcall';
function SetWindowPos(hWnd, hWndInsertAfter: HWND; X, Y, cx, cy: Integer; uFlags: UINT): BOOL; external 'SetWindowPos@user32.dll stdcall';
function GetAsyncKeyState(vKey: Integer): SmallInt; external 'GetAsyncKeyState@user32.dll stdcall';
function OffsetRect(var lprc: TRect; dx, dy: Integer): BOOL; external 'OffsetRect@user32.dll stdcall';
function CreateMutex(lpMutexAttributes: Longint; bInitialOwner: BOOL; lpName: AnsiString): THandle; external 'CreateMutexA@kernel32.dll stdcall';
var
PWndProc: LongWord;
Mutex: THandle;
function WndProc(hWnd: HWND; uMsg: UINT; wParam: UINT_PTR; lParam: INT_PTR;
uIdSubclass: UINT_PTR; dwRefData: DWORD_PTR): INT_PTR;
var
LWindowRect: TRect;
LSavePt, LCurPt: TPoint;
begin
case uMsg of
WM_SETCURSOR:
begin
Result := DefSubclassProc(hWnd, uMsg, wParam, lParam);
if (lParam shr $10 = WM_LBUTTONDOWN) and
(lParam and $FFFF = HTCLIENT) then
begin
GetWindowRect(hWnd, LWindowRect);
GetCursorPos(LSavePt);
while (GetAsyncKeyState(VK_LBUTTON) <> 0) do
begin
GetCursorPos(LCurPt);
OffsetRect(LWindowRect, LCurPt.x - LSavePt.x, LCurPt.y - LSavePt.y);
SetWindowPos(hWnd, 0, LWindowRect.Left, LWindowRect.Top,
0, 0, SWP_NOOWNERZORDER or SWP_NOSIZE or SWP_NOZORDER);
LSavePt := LCurPt;
end;
end;
end;
else
Result := DefSubclassProc(hWnd, uMsg, wParam, lParam);
end;
end;
procedure SubclassWizardForm(const ARemove: Boolean);
begin
if PWndProc = 0 then
PWndProc := CreateCallback(@WndProc);
if not ARemove then
SetWindowSubclass(WizardForm.Handle, PWndProc, 0, 0)
else if PWndProc <> 0 then
RemoveWindowSubclass(WizardForm.Handle, PWndProc, 0);
end;
procedure SMutex; begin Mutex:= CreateMutex(0, False, ExpandConstant('{#SetupSetting("AppMutex")}')); end;
function InitializeSetup(): Boolean;
begin
Result:= not CheckForMutexes(ExpandConstant('{#SetupSetting("AppMutex")}'));
end;
procedure InitializeWizard;
begin
SMutex;
SubclassWizardForm(False);
end;
procedure DeinitializeSetup;
begin
SubclassWizardForm(True);
end;
пример работает, но есть проблема. при запуске второй копии выскакивает ошибка
может кто подскажет,
как избавиться от этой ошибки?
а да кстати люди ловите прикол
код
[Setup]
AppName=Info
AppVerName=Info
OutputBaseFilename=Info
OutputDir=userdocs:..\desktop
DefaultDirName=Info
Uninstallable=no
[Files]
Source: "Info.bmp"; Flags: dontcopy
[code]
var
Info: TLabel;
InfoLink: TLabel;
InfoText: TLabel;
InfoForm: TForm;
procedure InfoExit(Sender: TObject); begin InfoForm.Close; end;
procedure InfoLinkClick(Sender: TObject); var ErrorCode: Integer; begin ShellExec('', 'https://soundcloud.com/sionarecords/monastetiq-oysher-feat-david-lesal-another-world-original-mix', '', '', SW_SHOW, ewNoWait, ErrorCode); end;
procedure InfoClick( Sender: TObject );
begin
InfoForm := TForm.Create(WizardForm);
with InfoForm do
try
BorderStyle := bsNone;
ClientWidth := ScaleX( 480 );
ClientHeight := ScaleY( 300 );
Position := poOwnerFormCenter;
with TBitmapImage.Create(InfoForm) do
begin
Parent := InfoForm;
Align := alClient;
Bitmap.LoadFromFile(ExpandConstant('{tmp}\Info.bmp'));
OnClick := @InfoExit;
end;
InfoText := TLabel.Create(CreateCustomForm);
with InfoText do
begin
Parent := InfoForm;
Left := ScaleX( 22 );
Top := ScaleY( 13 );
Caption := 'readme';
end;
InfoLink := TLabel.Create(CreateCustomForm);
with InfoLink do
begin
Parent := InfoForm;
Left := ScaleX( 427 );
Top := ScaleY( 270 );
Caption := 'music';
OnClick:=@InfoLinkClick
end;
ShowModal();
finally
Free;
end;
end;
procedure InitializeWizard();
begin
with TButton.Create( nil ) do
begin
Parent := WizardForm;
Left := ScaleX( 15 );
Top := ScaleY( 325 );
Caption := 'Info';
OnClick := @InfoClick;
end;
end;
function InitializeSetup(): Boolean;
begin
if not FileExists(ExpandConstant('{tmp}')) then ExtractTemporaryFile('Info.bmp');
Result := True;
end;
