unit InstUnit;
{ InstUnit - part of DELZIP demo #4. Freeware by Eric W. Engler and Chris Vleghert}
(************************************************************************
Copyright (C) 2009, 2010 by Russell J. Peters, Roger Aelbrecht,
Eric W. Engler and Chris Vleghert.
This file is part of TZipMaster Version 1.9.
TZipMaster is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
TZipMaster is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with TZipMaster. If not, see <http://www.gnu.org/licenses/>.
contact: problems@delphizip.org (include ZipMaster in the subject).
updates: http://www.delphizip.org
DelphiZip maillist subscribe at http://www.freelists.org/list/delphizip
************************************************************************)
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Registry, ShlObj
{$IfDef VER90} // Delphi2
,Ole2;
{$Else} // Delphi3+
,ComObj, ActiveX;
{$EndIf}
{$IfDef VER90} // Delphi2
type LongWord = Cardinal;
type WideString = Array[0..MAX_PATH] of WideChar;
type pShLinkType = ^IShellLink;
type ppShLinkType = ^pShLinkType;
type pFileType = ^IPersistFile;
type ppFileType = ^pFileType;
{$EndIf}
type
TInstForm = class( TForm )
GroupBox1: TGroupBox;
StartMenuCB: TCheckBox;
DesktopCB: TCheckBox;
RegistryCB: TCheckBox;
AssocCB: TCheckBox;
SendToCB: TCheckBox;
KillCB: TCheckBox;
UninstBut: TButton;
CancelBut: TButton;
InstBut: TButton;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
ProgramNameLabel: TLabel;
StartMenuRB: TRadioButton;
ProgramRB: TRadioButton;
procedure FormCreate( Sender: TObject) ;
procedure InstButClick( Sender: TObject );
procedure SetValInReg( RKey:HKey; KeyPath: String; ValName: String; NewVal: String );
procedure MakeAssociation( Ext: String; PgmToLinkTo: String );
procedure MakeLink( PgmPath, PgmArgs, LinkPath, Descr: String );
procedure CancelButClick( Sender: TObject );
procedure UninstButClick( Sender: TObject );
procedure RegDeleteKey( RKey:HKey; KeyPath: String );
procedure RemoveAssociation( Ext: String );
procedure FormActivate( Sender: TObject );
function AddBackslash( str_in: string ): string;
procedure StartMenuCBClick( Sender: TObject );
private
{ Private declarations }
public
{ Public declarations }
EXEName, EXETitle: String;
function GetSpecialFolder( aFolder: Integer; var Location: String ): LongWord;
end;
var
InstForm: TInstForm;
implementation
uses unit1;
{$R *.DFM}
procedure TInstForm.FormCreate( Sender: TObject );
begin
EXEName := ExtractFileName( ParamStr( 0 ) );
EXETitle := 'ViewZip - Delphi ZIP Auto Install Application Example';
ProgramNameLabel.Caption := ParamStr( 0 );
if Form1.AutoUninstall then
begin
ShowMessage( 'Now beginning ViewZip auto uninstall' );
UnInstButClick( Self );
end;
end;
procedure TInstForm.InstButClick( Sender: TObject );
var
path: String;
MenuDir: Integer;
begin
Screen.Cursor := crHourGlass;
if StartMenuCB.Checked then
begin
if StartMenuRB.Checked then
MenuDir := CSIDL_STARTMENU
else
MenuDir := CSIDL_PROGRAMS;
GetSpecialFolder( MenuDir, path );
MakeLink( ParamStr( 0 ), // the full pathname of this executable program
'', // no arguments
path + EXETitle + '.lnk',
'Sample Self-install Program' );
end;
if DesktopCB.Checked then
begin
GetSpecialFolder( CSIDL_DESKTOPDIRECTORY, path );
MakeLink( ParamStr( 0 ), // the full pathname of this executable program
'', // no arguments
path + EXETitle + '.lnk',
'Sample Install Program' );
end;
if SendToCB.Checked then
begin
GetSpecialFolder( CSIDL_SENDTO, path );
MakeLink( ParamStr( 0 ), // the full pathname of this executable program
'', // no arguments
path + EXETitle + '.lnk',
'Sample Install Program' );
end;
if RegistryCB.Checked then
begin
{ define the application path }
SetValInReg( HKEY_LOCAL_MACHINE,
'SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\' + EXEName,
'', { specify the default data item }
ParamStr( 0 ) ); { Full pathname with program name }
path:=ExtractFilePath(ParamStr(0));
SetValInReg( HKEY_LOCAL_MACHINE,
'SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\' + EXEName,
'Path', { specify the Path data item }
Copy( path, 1, Length( path )- 1 ) ); { Full pathname without end slash }
{ define the un-install command line }
SetValInReg( HKEY_LOCAL_MACHINE,
'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\' + EXEName,
'DisplayName',
EXETitle ); { show user this name in control panel }
SetValInReg( HKEY_LOCAL_MACHINE,
'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\' + EXEName,
'UninstallString',
ParamStr( 0 ) + ' /UNINSTALL' ); { pgm name and parameter }
{ define the main application program settings key }
SetValInReg( HKEY_LOCAL_MACHINE,
'SOFTWARE\' + EXEName,
'InstalledVersion',
'1.51' );
{ these are settings that only apply to the current logged-in user }
SetValInReg( HKEY_CURRENT_USER,
'SOFTWARE\' + EXEName,
'InstalledVersion',
'1.51' );
SetValInReg( HKEY_CURRENT_USER,
'SOFTWARE\' + EXEName,
'Setting1',
'y' );
SetValInReg( HKEY_CURRENT_USER,
'SOFTWARE\' + EXEName,
'Setting2',
'n' );
end;
if AssocCB.Checked then
MakeAssociation( 'zip', ParamStr( 0 ) );
Screen.Cursor := crDefault;
{$ifdef NEVER}
if KillCB.Checked then
KillMySelf( 0, False );
{$endif}
Close;
end;
{ Create a Win95 file association in the registry. This uses the Quick-and-
Dirty method used by Explorer when you right click on a file and choose
"Open With...". Basically, the file extension is created as a class, and
a dummy file type is created for that class to tell Win95 which program to
run. Once this is done, you can easily test it from a DOS Shell by typing:
START FILENAME.EXT
Be advised: This is where I expected file associations to be (because
there are already some associations there), but they seem to have no effect:
HKEY_CURRENT_USER,'Software\Microsoft\Windows\CurrentVersion\Extensions'
}
procedure TInstForm.MakeAssociation( Ext: String; PgmToLinkTo: String );
begin
{ ALL extensions must be in lowercase to avoid trouble! }
Ext := LowerCase( Ext );
if FileExists( PgmToLinkTo ) then
begin
SetValInReg( HKEY_CLASSES_ROOT,
'.' + ext, { extension we want to define }
'', { specify the default data item }
ext + '_auto_file' ); { This is the value of the default data item -
this referances our new type to be defined }
SetValInReg( HKEY_CLASSES_ROOT,
ext + '_auto_file', { this is the type we want to define }
'', { specify the default data item }
ext + ' Files'); { This is the value of the default data item -
this is the English description of the file type }
SetValInReg( HKEY_CLASSES_ROOT,
Ext + '_auto_file\DefaultIcon', { Create a file...DefaultIcon.}
'', { Specify the default data item.}
PgmToLinkTo + ',0' ); { Executable where icon is in and it's Sequence number.}
SHChangeNotify( SHCNE_ASSOCCHANGED, SHCNF_FLUSH, nil, nil );
// un-comment this if your file type can be viewed by Quick View
// SetValInReg( HKEY_CLASSES_ROOT,
// ext + '_auto_file\QuickView', { create a key for QuickView compat. }
// '', { specify the default data item }
// '*' ); { flag to tell Explorer that QuickView is OK }
SetValInReg( HKEY_CLASSES_ROOT,
ext + '_auto_file\shell\open\command', { create a file...open key }
'', { specify the default data item }
PgmToLinkTo + ' %1' ); { command line to open file with }
end
else
ShowMessage( 'Error: Program not found: ' + PgmToLinkTo );
end;
procedure TInstForm.RemoveAssociation( Ext: String );
begin
Ext := LowerCase( Ext );
RegDeleteKey( HKEY_CLASSES_ROOT,
'.' + ext ); { extension we want to undefine }
RegDeleteKey( HKEY_CLASSES_ROOT,
Ext + '_auto_file\DefaultIcon' );
RegDeleteKey( HKEY_CLASSES_ROOT,
ext + '_auto_file\shell\open\command' );
RegDeleteKey( HKEY_CLASSES_ROOT,
ext + '_auto_file' );
SHChangeNotify( SHCNE_ASSOCCHANGED, SHCNF_FLUSH, nil, nil );
end;
procedure TInstForm.RegDeleteKey( RKey: HKey; KeyPath: String );
begin
with TRegistry.Create do
try
RootKey := RKey;
// Under Win95, all keys under this one are auto. deleted also.
// But, under WinNT, the keys under this one will be left alone.
DeleteKey( KeyPath );
finally
Free;
end;
end;
{ Set a value in the registry. This is NOT related to the .LNK code.
This will create a new registry key if it doesn't already exist. }
procedure TInstForm.SetValInReg( RKey: HKey; KeyPath: String; ValName: String; NewVal: String );
begin
with TRegistry.Create do
try
RootKey := RKey;
OpenKey( KeyPath, True );
WriteString( ValName, NewVal );
finally
Free;
end;
end;
{$IfNDef VER90} // Delphi 3+
{* Make a Shell Link, also called a "shortcut".
* MakeLink - uses the shell's IShellLink and IPersistFile interfaces
* to create and store a shortcut to the specified object.
*
* PgmPath - address of a buffer containing the path of the object.
* LinkPath - address of a buffer containing the path where the shell link is to be stored.
* Descr - address of a buffer containing the description of the shell link.
* PgmArgs - address of a buffer containing the arguments for the shell link.
*}
procedure TInstForm.MakeLink( PgmPath, PgmArgs, LinkPath, Descr: String );
var
AnObj: IUnknown;
ShLink: IShellLink;
PFile: IPersistFile;
WFileName: WideString;
begin
if UpperCase( ExtractFileExt( LinkPath ) ) <> '.LNK' then
begin
ShowMessage( 'Error: link path extension must be .LNK' );
Exit;
end;
// access to the two interfaces of the object
AnObj := CreateComObject( CLSID_ShellLink );
ShLink := AnObj as IShellLink;
PFile := AnObj as IPersistFile;
// NOTE: We're using a COM Object, so all string args must be PChar
// set the link properties
ShLink.SetPath( PChar( PgmPath ) ); // also called the link target
ShLink.SetArguments( PChar( PgmArgs ) );
ShLink.SetWorkingDirectory( PChar( ExtractFilePath( PgmPath ) ) );
ShLink.SetDescription( PChar( Descr ) );
// Save with a WideString filename
WFileName := LinkPath;
PFile.Save( PWChar( WFileName ), False );
end;
{$Else}
// Delphi 2
procedure TInstForm.MakeLink( PgmPath, PgmArgs, LinkPath, Descr: String );
var
ShLink: pShLinkType;
pShLink: ppShLinkType;
hRes: HRESULT;
pFile: pFileType;
ppFile: ppFileType;
WFileName: Array[0..MAX_PATH] of WideChar;
begin
if UpperCase( ExtractFileExt( LinkPath ) ) <> '.LNK' then
begin
ShowMessage( 'Error: link path extension must be .LNK' );
Exit;
end;
hRes := CoInitialize( nil );
if (hRes = S_OK) or (hRes = S_FALSE) then
begin
if hRes = S_OK then
begin
// Get a pointer to the IShellLink interface.
hRes := CoCreateInstance( CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_IShellLink, pShLink );
if SUCCEEDED( hRes ) then
begin
// Set the path to the shortcut target, and add the description.
ShLink := @pShLink;
ShLink.SetPath( PChar( PgmPath ) );
ShLink.SetDescription( PChar( Descr ) );
ShLink.SetArguments( PChar( PgmArgs ) );
ShLink.SetIconLocation( PChar( PgmPath ), 0 );
ShLink.SetWorkingDirectory( PChar( ExtractFilePath( PgmPath ) ) );
// Query IShellLink for the IPersistFile interface for saving the
// shortcut in persistent storage.
hRes := ShLink.QueryInterface( IID_IPersistFile, ppFile );
if SUCCEEDED( hRes ) then
begin
pFile := @ppFile;
// Ensure that the string is ANSI.
MultiByteToWideChar( CP_ACP, 0, PChar( LinkPath ), -1, WFileName, MAX_PATH );
// Save the link by calling IPersistFile::Save.
pFile.Save( WFileName, False );
PFile.SaveCompleted( WFileName );
pFile.Release;
end;
ShLink.Release;
end;
end else
ShowMessage( 'COM already initialized' );
CoUninitialize;
end else // E_INVALIDARG, E_OUTOFMEMORY, o E_UNEXPECTED.
ShowMessage( 'COM library could not initialize' );
end;
{$EndIf}
procedure TInstForm.CancelButClick( Sender: TObject );
begin
Close;
end;
procedure TInstForm.UninstButClick( Sender: TObject );
var
path: String;
MenuDir: Integer;
begin
Screen.Cursor := crHourGlass;
if StartMenuCB.Checked then
begin
if StartMenuRB.Checked then
MenuDir := CSIDL_STARTMENU
else
MenuDir := CSIDL_PROGRAMS;
GetSpecialFolder( MenuDir, path );
DeleteFile( path + EXETitle + '.lnk' );
end;
if DesktopCB.Checked then
begin
GetSpecialFolder( CSIDL_DESKTOPDIRECTORY, path );
DeleteFile( path + EXETitle + '.lnk' );
end;
if SendToCB.Checked then
begin
GetSpecialFolder( CSIDL_SENDTO, path );
DeleteFile( path + EXETitle + '.lnk' );
end;
if RegistryCB.Checked then
begin
RegDeleteKey( HKEY_LOCAL_MACHINE,
'SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\' + EXEName );
RegDeleteKey( HKEY_LOCAL_MACHINE,
'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\' + EXEName );
RegDeleteKey( HKEY_LOCAL_MACHINE,
'SOFTWARE\' + EXEName );
RegDeleteKey( HKEY_CURRENT_USER,
'SOFTWARE\' + EXEName );
end;
if AssocCB.Checked then
RemoveAssociation( 'zip' );
Screen.Cursor := crDefault;
if NOT Form1.AutoUnInstall then
{ if we are auto-uninstalling, then we are still in OnCreate,
so we can't close this form yet. }
Close;
end;
procedure TInstForm.FormActivate( Sender: TObject );
begin
if Form1.AutoUnInstall then
PostMessage( Handle, WM_CLOSE, 0, 0 );
end;
// Add a backslash to a string if it doesn't already end in one,
// AND if the string has a non-zero length.
function TInstForm.AddBackslash( str_in: string ): string;
begin
Result := str_in;
if Result = '' then
Exit;
if Result[Length( Result )] <> '\' then
Result := Result + '\';
end;
procedure TInstForm.StartMenuCBClick( Sender: TObject );
begin
StartMenuRB.Enabled := StartMenuCB.Checked;
ProgramRB.Enabled := StartMenuCB.Checked;
end;
//---------------------------------------------------------------------------
{* Folder types are a.o.
* CSIDL_DESKTOPDIRECTORY, CSIDL_STARTMENU, CSIDL_SENDTO,
* CSIDL_PROGRAMS, CSIDL_STARTUP etc.
*}
function TInstForm.GetSpecialFolder( aFolder: Integer; var Location: String ): LongWord;
var
pidl: PItemIDList;
hRes: HRESULT;
RealPath: Array[0..MAX_PATH] of Char;
Success: Boolean;
begin
Result := 0;
hRes := SHGetSpecialFolderLocation( Handle, aFolder, pidl );
if hRes = NO_ERROR then
begin
Success := SHGetPathFromIDList( pidl, RealPath );
if Success then
Location := String( RealPath ) + '\'
else
Result := LongWord( E_UNEXPECTED );
GlobalFreePtr( pidl );
end else
Result := hRes;
end;
end.