|
|
 |
|
InstallShield yada Innostup gibi programlarını kullanmak istemeyenler için kendi setup programını hazırlayacak bir uygulama.
Setup programı 2 kısımdan oluşur:Install ve Uninstall,yani 2 proje yapılacak.
Install programının yaptığı işlemler şunlar:
1-Kaynak dizini belirtile disk sürücüsüne kopyalar.
2-Programın masaüstüne,kısayolunu atar.
3-Başlat->Programlar'da Program Grubu oluşturur.
4-Programın daha sonra kaldırılması için Program Ekle/Kaldır da görünmesi için
"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\Cur rentVersion\Uninstall" altında kaydını yapar.
5-Uninstall.exe dosyasını Windows dizinine kopyalar.
Uninstall.exe programının yaptığı işlemler:
1-dizinsil fonksiyonu ile programın dizinini disk sürücüsünden kaldırır.Uninstall.exe nin kendisi Windows dizininde olduğundan bundan etkilenmez.yani sildiği dizinin içinde olmamalı.
2-Başlat->Programlar'da Program Grubunu kaldırı. normalde bunun çalışması gerkirdi.fakat bir yerde küçük bir hata mı var ,bir türlü program grubunu kaldırmıyor.
3-Registry de "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\Cur rentVersion\Uninstall" anahtarını siler.
4-DeleteEXE prosedürü ile kendini siler.
kod:
unit Setup;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, FileCtrl, ComCtrls, DdeMan,ShlObj, ComObj,
ActiveX,Registry;
type
TForm1 = class(TForm)
BitBtn1: TBitBtn;
ProgressBar1: TProgressBar;
BitBtn3: TBitBtn;
Label6: TLabel;
DdeClientConv1: TDdeClientConv;
DriveComboBox1: TDriveComboBox;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
ListBox1: TListBox;
procedure BitBtn1Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure BitBtn3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
Inputdir, Outputdir,dizin_adi:string;
filecount:integer;
function FileCopyExit(inpath,outpath,filename:string; var canclose:boolean):boolean;
end;
var
Form1: TForm1;
implementation
uses UCopyFolder;
{$R *.dfm}
//kaynak dizinden(inpath) hedef dizine(outpath) dosyaları kopyalar
function TForm1.FileCopyExit(inpath,outpath,filename:string ; var canclose:boolean):boolean;
begin
result:=true;
inc(filecount);
if tag<>0 then result:=false; {user pressed the stop button, abort}
//memo1.lines.add(format('%s from %s to %s',[filename,inpath,outpath]));
Application.ProcessMessages;
ProgressBar1.Position:= filecount; //kopyalama sürecini progressbarda göster
Label2.Caption:= filename; //kopyalanan dosya adını Label2'de göster
Label2.Refresh;
Label2.Repaint;
end;
//FindFiles prosedürü,dizin ve alt dizinlerdeki toplam dosya sayısını verir
// Recursive procedure to build a list of files
procedure FindFiles(FilesList: TStringList; StartDir, FileMask: string);
var
SR: TSearchRec;
DirList: TStringList;
IsFound: Boolean;
i: integer;
begin
if StartDir[length(StartDir)] <> '\' then
StartDir := StartDir + '\';
{ Build a list of the files in directory StartDir
(not the directories!) }
IsFound :=
FindFirst(StartDir+FileMask, faAnyFile-faDirectory, SR) = 0;
while IsFound do begin
FilesList.Add(StartDir + SR.Name);
IsFound := FindNext(SR) = 0;
end;
FindClose(SR);
// Build a list of subdirectories
DirList := TStringList.Create;
IsFound := FindFirst(StartDir+'*.*', faAnyFile, SR) = 0;
while IsFound do begin
if ((SR.Attr and faDirectory) <> 0) and
(SR.Name[1] <> '.') then
DirList.Add(StartDir + SR.Name);
IsFound := FindNext(SR) = 0;
end;
FindClose(SR);
// Scan the list of subdirectories
for i := 0 to DirList.Count - 1 do
FindFiles(FilesList, DirList, FileMask);
DirList.Free;
end;
//---------KISAYOL OLUŞTUR---------------------------------------------------
//CreateLink('c:\windows\notepad.exe','c:\MyNotePad. lnk','','');
// Desktop, Start Menu ve Quick Launch'da oluştur
//CreateShortCut('Not defteri', 'c:\windows\notepad.exe', 'c:\windows\',[slDesktop, slStartMenu, slQuickLaunch]);
// Sadece Desktop ve Quick Launch'da oluştur
//CreateShortCut('Not defteri', 'c:\windows\notepad.exe', 'c:\windows\',[slDesktop, slQuickLaunch]);
// Sadece Desktop oluştur
//CreateShortCut('Not defteri', 'c:\windows\notepad.exe', 'c:\windows\',[slDesktop]);
type
TShortCutLocation = (slDesktop, slStartMenu, slQuickLaunch);
TShortCutLocations = set of TShortCutLocation;
procedure CreateShortCut(Description, ApplicationPath, StartFolder: string;Locations: TShortCutLocations);
var
MyObject : IUnknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
Directory : string;
WFileName : WideString;
MyReg : TRegIniFile;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
with MySLink do begin
{ Parametreler icin kullanilabilir:
SetArguments(PChar(Application Path));
}
MySLink.SetPath(PChar(ApplicationPath));
SetRelativePath(PChar(StartFolder),0);
SetWorkingDirectory(PChar(StartFolder));
SetDescription(PChar(Description));
SetIconLocation(PChar(ApplicationPath),0);
end;
MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\Cur rentVersion\Explorer');
// Desktop'a kisa yol olusturmak icin }
if slDesktop in Locations then
begin
Directory := MyReg.ReadString('Shell Folders','Desktop','');
WFileName := Directory+ '\' + Description + '.lnk';
MyPFile.Save(PWChar(WFileName) ,False);
end;
// Start Menu için
if slStartMenu in Locations then
begin
Directory := MyReg.ReadString('Shell Folders','Programs','');
{ Alt Klasörde oluşturmak için:
Directory = Directory + '\KlasorAdi';
CreateDir(Directory); }
WFileName := Directory+ '\' + Description + '.lnk';
MyPFile.Save(PWChar(WFileName) ,False);
end;
// QuickLaunch için
if slQuickLaunch in Locations then
begin
Directory := MyReg.ReadString('Shell Folders','Appdata','');
WFileName := Directory +'\Microsoft\Internet Explorer\Quick Launch\' +Description + '.lnk';
MyPFile.Save(PWChar(WFileName) ,False);
end;
MyReg.Free;
end;
//unistall programınının yolunu registry e verir
procedure CreateSoftwareEntry(const DisplayName, IconPath, Version, Publisher, UninstallPath: String);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVe rsion\Uninstall\' + DisplayName, true) then
begin
Reg.WriteString('DisplayIcon', IconPath);
Reg.WriteString('DisplayName', DisplayName);
Reg.WriteString('DisplayVersion', Version);
Reg.WriteString('Publisher', Publisher);
Reg.WriteString('UninstallString', UninstallPath);
Reg.CloseKey;
end;
finally
Reg.Free;
end;
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
var
dosya: TextFile;
satir,str:string;
FilesList: TStringList;
file_count:integer;
Reg:TRegistry;
GUID:string;
strGroup : string;
strExeName : string;
strExeFile : string;
strMacro : string;
bootdir:string;
begin
//DriveComboBox1.Drive yüklenecek disk sürücüsü seçilir
InputDir:=ExtractFilePath(Application.ExeName)+'\P ersonel Takip';
OutputDir:=DriveComboBox1.Drive+':\Personel Takip';
if not DirectoryExists(InputDir) then begin
Application.MessageBox('Personel Takip Kaynak Yükleme Dizini Bulunamadı...','PROGRAM YÜKLEME HATASI',MB_OK);
exit;
end;
if (Application.MessageBox('Programı Yüklemek İstiyor musunuz...?','UYARI',MB_YESNO)=IDNO) then begin
exit;
end;
if not DirectoryExists(OutputDir) then begin
CreateDir(OutputDir);
end else begin
if (Application.MessageBox('Personel Takip Programı Önceden Yüklenmiş...Devam Etmek İstiyor musunuz...?','UYARI',MB_YESNO)=IDNO) then begin
exit;
end;
end;
//----kaynak dizin ve alt dizinlerdeki içindeki toplam dosya sayısı---------
FilesList := TStringList.Create;
try
FindFiles(FilesList, InputDir, '*.*');
ListBox1.Items.Assign(FilesList);
file_count:=FilesList.Count;
finally
FilesList.Free;
end;
//--------------------------------------------------------------------------
ProgressBar1.Min:=0;
ProgressBar1.Max:= file_count;
ProgressBar1.Visible:=true;
//---kaynak klasör,alt klasör ,dosyaları kopyala---------------------
tag:=0;
filecount:=0;
screen.cursor:=crHourGlass;
copyfolder(InputDir,OutputDir,'*.*', 0,true,true,FileCopyExit);
screen.cursor:=crDefault;
Label2.Caption:='';
Application.MessageBox('Yükleme Tamamlandı...','Program Yükleme',MB_OK);
//unistal.exe yi Windows klasörüne kopyala
//bootdir ile windows'un yüklü olduğu disk sürücüsünü bul
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVer sion\Setup', false) then
bootdir:=Reg.ReadString('BootDir');
Reg.CloseKey;
Reg.Free;
CopyFile(PChar(InputDir+'\Uninstall001.exe'),PChar (bootdir+'Windows\Uninstall001.exe'),true);
//unistal programını registry e kaydet
CreateSoftwareEntry('Personel Takip', OutputDir+'\Personel.exe', '1.0', 'TAIVAN BSC BIOMETRIC CO. INT.', bootdir+'Windows\Uninstall001.exe');
//başlat->programlarda group oluştur
strGroup := 'Personel Takip';
strExeName := 'Personel';
strExeFile := OutputDir+'\Personel.exe';
DdeClientConv1.SetLink('PROGMAN','PROGMAN') ;
strMacro := '[CreateGroup(' + strGroup + ')]';
DDEClientConv1.ExecuteMacro(PChar(strMacro),False) ;
//strMacro := '[ShowGroup(' + strGroup + ',1)]';
//DDEClientConv1.ExecuteMacro(PChar(strMacro),False) ;
strMacro := '[AddItem("' + strExeFile + '","' + strExeName + '")]';
DDEClientConv1.ExecuteMacro(PChar(strMacro),False) ;
if (Assigned(DDEClientConv1)) then begin
DDEClientConv1.CloseLink;
end;
//Desktop a kısayol oluştur
if FileExists(OutputDir+'\Personel.exe') then
CreateShortCut('Personel Takip', OutputDir+'\Personel.exe', OutputDir,[slDesktop]);
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
Label2.Caption:='';
//ProgressBar1.Visible:=false;
end;
procedure TForm1.BitBtn3Click(Sender: TObject);
begin
Close;
end;
Setup programı "UCopyFolder" adlı uniti kullanıyor.dizin/alt dizinler
ve bunların içindeki dosyaları kopyalama işlemini bu unit içindeki
"copyfolder" fonksiyonu yapıyor.UCopyFolder.pas alın size kaynak kodu:
unit UCopyFolder;
{Copyright © 2006, Gary Darby, Linklerin Görülmesine İzin Verilmiyor
Linki Görebilmek İçin Üye Ol veya Giriş Yapwww.DelphiForFun.org
This program may be used or modified for any non-commercial purpose
so long as this original notice remains in place.
All other rights are reserved
}
{CopyFolder procedure copies files matching a given mask from one folder to
another. Parameters are;
FromFolder: Tha path to the folder containing the files to be copied
ToFolder: The path to the folder to receiver the files
Mask: A file mask to cntol which files are selected ('*.* = All files)
DupFileOpts: Four options are available when the file already exists:
1 ==> skip the file
2 ==> always copy the file
3 ==> copy the file if it is newer than the exitising copy
4 ==> ask the user what actoion to take
CopySubFolders: Files in subfolders of the specified Inopath folder will also be
copied if this parameter is true.
ResetreadOnly: If input files marked as "Readonly" will have that attribute
removed in the target location.
FileExit: The address of optional method (function of object) specifying a
user procedure to be called before each file is copied.
If the callback procedure is specified, it receives 4 parameters:
Inpath: Path to the input file.
OutputPath: path where the fle will be copied.
Filename: Name of the file to be copied.
Cancopy: Boolean parameter defaulting to true. Set "Cancopy" to
false to skip copying this file.
The FileExit function must return true if copying is to continmue,
and false to abort the copy procedure without copying further files.
}
interface
Uses windows,sysutils,dialogs,controls, forms, filectrl,masks;
type
TCopyFolderExit = function(inpath,outpath,filename:string;
var Cancopy:boolean):boolean of object;
function copyfolder(fromfolderIn, tofolderIn,mask:string; dupfileopts:integer;
copysubfolders, ResetReadOnly:boolean):boolean; overload;
function copyfolder(fromfolderIn, tofolderIn,mask:string; dupfileopts:integer;
copysubfolders, ResetReadOnly:boolean;
FileExit:TCopyFolderExit):boolean; overload;
implementation
{Define a Dummyclass to hold a dummfileexit method to provide a way for
the overloaded CopyFolder version without the file exit to pass this
function as a parameter to the overloaded verion that does the work}
type Tdummyclass = class(TObject)
function dummyfileexit(inpath,outpath,filename:string;
var Cancopy:boolean):boolean;
end;
{Dummy class to provide a instance of the dummyFileExit method required for the
overloaded version of CopyFolder}
var dummyclass:TDummyclass;
function Tdummyclass.dummyfileexit(inpath,outpath,filename: string;
var Cancopy:boolean):boolean;
begin {code doesntl matter since it will never be called}
result:=true;
end;
{*********** CopyFolder ***********}
function copyfolder(fromfolderIn, tofolderIn,mask:string; dupfileopts:integer;
copysubfolders, ResetReadOnly:boolean;
FileExit:TCopyFolderExit):boolean; overload;
{Copy files in "fromfolder" to "tofolder", creating tofolder if necessary.
If file exists in "tofolder" then action depends on value of "sync" parameter.
If "sync" is false, always copy, replacing existing file if necessary, if
"sync" is true, copy file if it does not exist in "tofolder" or it exists
in "tofolder" with an older date. }
var
f:TSearchrec;
r:integer;
mr:integer;
fromname,toname:string;
fromfolder,tofolder:string;
fromdate,todate:TDatetime;
//cancopy:boolean;
{----------- CopyAFile ----------}
procedure copyafile(FailExists:boolean);
var cancopy:boolean;
begin
cancopy:=true;
{This is just a substitute for "nil" testing for a
normal function (not a methof type function}
if @fileExit<>@tdummyclass.dummyfileexit {nil}
then result:=fileExit(fromfolder,tofolder,f.name,cancop y);
if cancopy then
begin
copyfile(pchar(fromname),pchar(toname),FailExists) ;
if resetreadonly and ((f.attr and faReadOnly)<>0)
then filesetattr(toname, f.attr and (not FAReadonly));
end;
end;
begin
result:=TRUE; {default}
fromfolder:=includeTrailingBackslash(fromfolderIn) ;
tofolder:=includeTrailingBackslash(tofolderIn);
if not directoryexists(tofolder)
then
if not createdir(tofolder) then
begin
raise Exception.Create('Cannot create '+tofolder);
result:=false;
end;
if result then
begin
r:= FindFirst(fromfolder+'*.*', FaAnyFile, F);
while (r=0) and result do
begin
If (length(f.name)>0) and (Uppercase(F.name)<>'RECYCLED')
and (F.name[1]<>'.') and (F.Attr and FAVolumeId=0)
then
begin
if ((F.Attr and FADirectory) >0) {get files from the next lower level}
then
begin
if copysubfolders
then result:=Copyfolder(fromfolder+F.Name+'\',
tofolder+f.name+'\', mask,
dupfileopts, copysubfolders, resetreadonly,FileExit)
end
else
try
if matchesmask(f.name,mask) then
begin
fromname:=fromfolder+f.name;
toname:=tofolder+f.name;
if fileexists(toname) then
begin
todate:=filedatetodatetime(fileage(toname));
fromdate:=filedatetodatetime(f.time);
case
dupfileopts of
1:{replace}
copyafile(false); {(pchar(fromname),pchar(toname),true); }
2:{replace if newer}
begin
if todate>fromdate then copyafile(false){(pchar(fromname),pchar(toname),tr ue)}
end;
3: {ask}
begin
mr:= messagedlg('Replace '+toname +' created '
+formatdatetime(shortdateformat +' '+shorttimeformat,todate)
+#13+ 'with '+fromname+' created '
+FORMATDATETIME(SHORTDATEFORMAT +' '+SHORTTIMEFORMAT,FROMDATE),
mtconfirmation, [mbyes,mbno,mbcancel],0);
if mr=mryes then copyafile(false) {(pchar(fromname),pchar(toname),true) }
else if mr= mrcancel then result:=false;
end;
end; {case}
end {fileexists}
else copyafile(false);
end;{matchesmask}
except
showmessage('Invalid mask "'+mask+'" entered, see documentation');
result:=false;
end; {try}
end;
r:=Findnext(F);
end;
FindClose(f);
end;
end;
{************** CopyFolder (w/o Callback ***********8}
function copyfolder(fromfolderIn, tofolderIn,mask:string; dupfileopts:integer;
copysubfolders, ResetReadOnly:boolean):boolean; overload;
{Copyfolder version w/o callback call to fileExit, call a "do nothing" version}
begin
result := copyfolder(fromfolderIn, tofolderIn,mask,dupfileopts,
copysubfolders, ResetReadOnly, dummyclass.DummyFileExit);
end;
//initialization
// dummyclass:=TDummyClass.create;
end.
Uninstall programı için ise kod:
unit Uninstall0001;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, DB, ADODB,Shellapi,Registry, DdeMan,StrUtils;
type
TfrmUnsetup = class(TForm)
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
DdeClientConv1: TDdeClientConv;
Label1: TLabel;
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmUnsetup: TfrmUnsetup;
implementation
{$R *.dfm}
//programın yüklü olduğu dizini sil
//Uses Shellapi;
function dizinsil(FilesOrDir: string): boolean;
var
F: TSHFileOpStruct;
From: string;
Resultval: integer;
begin
FillChar(F, SizeOf(F), #0);
From := FilesOrDir + #0;
Screen.Cursor := crHourGlass;
try
F.wnd := 0;
F.wFunc := FO_DELETE;
F.pFrom := PChar(From);
F.pTo := nil;
F.fFlags := FOF_ALLOWUNDO or
FOF_NOCONFIRMATION or
FOF_SIMPLEPROGRESS or
FOF_FILESONLY;
F.fAnyOperationsAborted := False;
F.hNameMappings := nil;
Resultval := ShFileOperation(F);
Result := (ResultVal = 0);
finally
Screen.Cursor := crDefault;
end;
end;
//unistall program exe sini sil
procedure DeleteEXE;
function GetTmpDir: string;
var
pc: PChar;
begin
pc := StrAlloc(MAX_PATH + 1);
GetTempPath(MAX_PATH, pc);
Result := string(pc);
StrDispose(pc);
end;
function GetTmpFileName(ext: string): string;
var
pc: PChar;
begin
pc := StrAlloc(MAX_PATH + 1);
GetTempFileName(PChar(GetTmpDir), 'uis', 0, pc);
Result := string(pc);
Result := ChangeFileExt(Result, ext);
StrDispose(pc);
end;
var
batchfile: TStringList;
batchname: string;
begin
batchname := GetTmpFileName('.bat');
FileSetAttr(ParamStr(0), 0);
batchfile := TStringList.Create;
with batchfile do
begin
try
Add(':Label1');
Add('del "' + ParamStr(0) + '"');
Add('if Exist "' + ParamStr(0) + '" goto Label1');
Add('rmdir "' + ExtractFilePath(ParamStr(0)) + '"');
Add('del ' + batchname);
SaveToFile(batchname);
ChDir(GetTmpDir);
Application.MessageBox('Program Kaldırıldı....','Uninstalling program.',MB_OK);
WinExec(PChar(batchname), SW_HIDE);
finally
batchfile.Free;
end;
Halt;
end;
end;
procedure TfrmUnsetup.BitBtn1Click(Sender: TObject);
var
Reg: TRegistry;
grup,str:string;
strGroup : string;
strExeName : string;
strExeFile : string;
strMacro : string;
p1char;
ProgTitel:string;
begin
if Application.MessageBox('Programı Kaldırmak İstiyor musunuz....?','UYARI',MB_YESNO)=ID_NO then
exit;
try
//registry de DisplayIcon anahtarından programın adını al
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVer sion\Uninstall\Personel Takip', false) then
grup:=LeftStr(Reg.ReadString('DisplayIcon'),13);
Reg.CloseKey;
Reg.Free;
//unistal programının registry kaydını sil
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVer sion\Uninstall', false) then
Reg.DeleteKey('Personel Takip');
Reg.CloseKey;
Reg.Free;
//başlat->programlar grubunu kaldır
strGroup := grup;
strExeName := 'Personel';
strExeFile := grup+'\Personel.exe';
DdeClientConv1.SetLink('PROGMAN','PROGMAN') ;
strMacro := '[DeleteItem("' + strExeFile + '","' + strExeName + '")]';
DDEClientConv1.ExecuteMacro(PChar(strMacro),False) ;
if (Assigned(DDEClientConv1)) then
DDEClientConv1.CloseLink;
//programı sil
dizinsil(grup);
//exe kendini silsin
DeleteEXE;
except
Application.MessageBox('Program Kaldırılamadı....','HATA',MB_OK);
end;
end;
procedure TfrmUnsetup.BitBtn2Click(Sender: TObject);
begin
Close;
end;
end.
|
