Ip adresinin, ağ maskesinin ve ağ geçitinin değiştirilmesi
Dikkat bu kodun çalışması için ağ bağlantınızın ismini aşağıdaki kısımda belirtmelisiniz.
Eğer ismi yanlış girerseniz ip adresi değiştirilemedei mesajını alırsınız.
Genellikle ağ bağlantısının ismi türkçe windowslarda "Yerel Ağ Bağlantısı" dır.
Eğer ağ bağlantınızı ismi farklıysa o ismi yazı çalıştığını göreceksiniz.
Uzaktaki bir makinanın ip adresini, ağ maskesini ve ağ geçitini değiştirebilirsiniz.
Çok güzel bir özellik.
Eğer ağ bağlantısı isminin ne olduğunu bilmiyorsanız:
Ağ bağlantılarım>Ağ bağlantılarını görüntüle deyin,
Hangi bağlantının ip adresini değiştirmek istiyorsanız onun ismini yazın
DÜŞÜNÜN BİRRR KENDİ DHCP Serverinizi yazıp tüm ipleri kendi programınızdan dağıtabilirsiniz.
Dikkat! İnternet bağlantınızda sorun çıkabilir. Bunun nedenni tcp ayarlarını değiştirmesidir.
DNS ayarlarını da değiştirmeniz gerekebilir. Yerel ağda herhangi bir sorun çıkmıyor.
procedure TForm1.Button1Click(Sender: TObject);
function ChangeIp(ConnectionName,Ip,Netmask,Gateway:string):boolean;
function ExecAndWait(FileName:String; Visibility:integer):integer;
var
zAppName:array[0..512] of char;
zCurDir:array[0..255] of char;
WorkDir:String;
StartupInfo:TStartupInfo;
ProcessInfo:TProcessInformation;
Resultado: DWord;
begin
StrPCopy(zAppName,FileName);
GetDir(0,WorkDir);
StrPCopy(zCurDir,WorkDir);
FillChar(StartupInfo,Sizeof(StartupInfo),#0);
StartupInfo.cb := Sizeof(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not CreateProcess(nil,
zAppName, { pointer to command line string }
nil, { pointer to process security attributes}
nil, { pointer to thread security attributes}
false, { handle inheritance flag }
CREATE_NEW_CONSOLE or { creation flags }
NORMAL_PRIORITY_CLASS,
nil, { pointer to new environment block }
nil, { pointer to current directory name }
StartupInfo, { pointer to STARTUPINFO }
ProcessInfo) then Result := -1 { pointer to PROCESS_INF }
else begin
WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess,Resultado);
Result := Resultado;
end;
end;
begin
Result:=( ExecAndWait( 'netsh interface ip set address "'+
ConnectionName+'" '+
' static '+Ip+ ' '+NetMask +' '+GateWay+' 1',sw_hide)=0 );
end;
begin
if NOT ChangeIp( 'Yerel Ağ Bağlantısı',
'192.168.1.50',
'255.255.255.0',
'192.168.1.1') then showmessage('IP adresi değiştirilemedi')
else showmessage('Ip adresi hatasız bir şekilde değişti');
//ilk parametre ağ bağlantısı ismi
//ikincisi ip adresi ne olsun
//3. parametre ağ maskesi ne olsun
//4. parametre ağ geçidi ne olsun(genellikle modem adresi olur)
end;
Delphi - .....................................
Ekran kartının isminin-modelinin alınması
procedure TForm1.Button1Click(Sender: TObject);
var
lpDisplayDevice: TDisplayDevice;
dwFlags: DWORD;
cc: DWORD;
begin
lpDisplayDevice.cb := sizeof(lpDisplayDevice);
dwFlags := 0;
cc:= 0;
while EnumDisplayDevices(nil, cc, lpDisplayDevice , dwFlags) do
begin
Inc(cc);
memo1.lines.add(lpDisplayDevice.DeviceString); {there is also additional information in lpDisplayDevice}
end;
end;
Delphi - .....................................
Ekran kartının isminin-modelinin alınması
procedure TForm1.Button1Click(Sender: TObject);
var
lpDisplayDevice: TDisplayDevice;
dwFlags: DWORD;
cc: DWORD;
begin
lpDisplayDevice.cb := sizeof(lpDisplayDevice);
dwFlags := 0;
cc:= 0;
while EnumDisplayDevices(nil, cc, lpDisplayDevice , dwFlags) do
begin
Inc(cc);
memo1.lines.add(lpDisplayDevice.DeviceString); {there is also additional information in lpDisplayDevice}
end;
end;
Delphi - .....................................
indy udp ile uzaktaki bilgisayarı açmak
Bu işlem için açılacak bilgisayarın bios ayarının yapılmış olması gerekir
Bios'ta wake on lan gibi bir özellik varsa enable yapın
Kullanımı: WakeOnLan('00-D0-B7-E2-A1-A0');
Mac adresinin bulunmasıyla ilgili örnekler var zaten...
Kodu:
uses idUDPClient;
// ==========================================================================
// Wakes a machine on lan
// AMacAddress is 17 char MAC address.
// eg. '00-C0-4F-0A-3A-D7'
// ==========================================================================
procedure WakeOnLan(const AMacAddress : string);
type
TMacAddress = array [1..6] of byte;
TWakeRecord = packed record
Waker : TMACAddress;
MAC : array[0..15] of TMACAddress;
end;
var i : integer;
WR : TWakeRecord;
MacAddress : TMacAddress;
UDP : TIdUDPClient;
sData : string;
begin
// Convert MAC string into MAC array
fillchar(MacAddress,SizeOf(TMacAddress),0);
sData := trim(AMacAddress);
if length(sData) = 17 then begin
for i := 1 to 6 do begin
MacAddress[i] := StrToIntDef('$' + copy(sData,1,2),0);
sData := copy(sData,4,17);
end;
end;
for i := 1 To 6 do WR.Waker[i] := $FF;
for i := 0 to 15 do WR.MAC[i] := MacAddress;
// Create UDP and Broadcast data structure
UDP := TIdUDPClient.Create(nil);
UDP.Host := '255.255.255.255';
UDP.Port := 32767;
UDP.BroadCastEnabled := true;
UDP.SendBuffer(WR,SizeOf(TWakeRecord));
UDP.BroadcastEnabled := false;
UDP.Free;
end;
Delphi - .....................................
indy udp ile uzaktaki bilgisayarı açmak
Bu işlem için açılacak bilgisayarın bios ayarının yapılmış olması gerekir
Bios'ta wake on lan gibi bir özellik varsa enable yapın
Kullanımı: WakeOnLan('00-D0-B7-E2-A1-A0');
Mac adresinin bulunmasıyla ilgili örnekler var zaten...
Kodu:
uses idUDPClient;
// ==========================================================================
// Wakes a machine on lan
// AMacAddress is 17 char MAC address.
// eg. '00-C0-4F-0A-3A-D7'
// ==========================================================================
procedure WakeOnLan(const AMacAddress : string);
type
TMacAddress = array [1..6] of byte;
TWakeRecord = packed record
Waker : TMACAddress;
MAC : array[0..15] of TMACAddress;
end;
var i : integer;
WR : TWakeRecord;
MacAddress : TMacAddress;
UDP : TIdUDPClient;
sData : string;
begin
// Convert MAC string into MAC array
fillchar(MacAddress,SizeOf(TMacAddress),0);
sData := trim(AMacAddress);
if length(sData) = 17 then begin
for i := 1 to 6 do begin
MacAddress[i] := StrToIntDef('$' + copy(sData,1,2),0);
sData := copy(sData,4,17);
end;
end;
for i := 1 To 6 do WR.Waker[i] := $FF;
for i := 0 to 15 do WR.MAC[i] := MacAddress;
// Create UDP and Broadcast data structure
UDP := TIdUDPClient.Create(nil);
UDP.Host := '255.255.255.255';
UDP.Port := 32767;
UDP.BroadCastEnabled := true;
UDP.SendBuffer(WR,SizeOf(TWakeRecord));
UDP.BroadcastEnabled := false;
UDP.Free;
end;
Delphi - .....................................
hızlı bir şekilde ekran resmini almak
const
cTileSize = 50;
function TForm1.GetScreenShot: TBitmap;
var
Locked: Boolean;
X, Y, XS, YS: Integer;
Canvas: TCanvas;
R: TRect;
begin
Result := TBitmap.Create;
Result.Width := Screen.Width;
Result.Height := Screen.Height;
Canvas := TCanvas.Create;
Canvas.Handle := GetDC(0);
Locked := Canvas.TryLock;
try
XS := Pred(Screen.Width div cTileSize);
if Screen.Width mod cTileSize > 0 then
Inc(XS);
YS := Pred(Screen.Height div cTileSize);
if Screen.Height mod cTileSize > 0 then
Inc(YS);
for X := 0 to XS do
for Y := 0 to YS do
begin
R := Rect(
X * cTileSize, Y * cTileSize, Succ(X) * cTileSize,
Succ(Y) * cTileSize
);
Result.Canvas.CopyRect(R, Canvas, R);
end;
finally
if Locked then
Canvas.Unlock;
ReleaseDC(0, Canvas.Handle);
Canvas.Free;
end;
end;
Delphi - .....................................
hızlı bir şekilde ekran resmini almak
const
cTileSize = 50;
function TForm1.GetScreenShot: TBitmap;
var
Locked: Boolean;
X, Y, XS, YS: Integer;
Canvas: TCanvas;
R: TRect;
begin
Result := TBitmap.Create;
Result.Width := Screen.Width;
Result.Height := Screen.Height;
Canvas := TCanvas.Create;
Canvas.Handle := GetDC(0);
Locked := Canvas.TryLock;
try
XS := Pred(Screen.Width div cTileSize);
if Screen.Width mod cTileSize > 0 then
Inc(XS);
YS := Pred(Screen.Height div cTileSize);
if Screen.Height mod cTileSize > 0 then
Inc(YS);
for X := 0 to XS do
for Y := 0 to YS do
begin
R := Rect(
X * cTileSize, Y * cTileSize, Succ(X) * cTileSize,
Succ(Y) * cTileSize
);
Result.Canvas.CopyRect(R, Canvas, R);
end;
finally
if Locked then
Canvas.Unlock;
ReleaseDC(0, Canvas.Handle);
Canvas.Free;
end;
end;
Delphi - .....................................
bağlantı ipsini bulmak
bağlantı ip nizi bulmak. Bu işlem için bir internet sitesinden yararlanılıyor
İnternet sitesinde modeminizin ip si yazıyor. Bu ip alınıyor.
unit Unit1;
{IP Internet par Caribensila}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, OleCtrls, SHDocVw, ExtCtrls;
type
TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
WebBrowser1: TWebBrowser;
procedure Button1Click(Sender: TObject);
procedure WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
private
{ Déclarations privées }
public
{ Déclarations publiques }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
var
Tentative : Byte;
procedure Connexion;
begin
if (Tentative = 1) then { 1ère tentative}
Form1.WebBrowser1.Navigate('http://checkip.dyndns.org');
if (Tentative = 2) then { 2ème tentative}
Form1.WebBrowser1.Navigate('http://www.adresseip.com');
end;
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
S, IP : String;
i :Integer;
begin
beep;
// La page téléchargée est réduite en chaîne.
S := WebBrowser1.OleObject.Document.Body.InnerHTML;
If (Tentative = 2) then
begin
// L'adresse IP est extraite de cette chaîne.
if (Pos('Votre adresse IP est',S) <> 0) then
begin
i := Pos('Votre adresse IP est',S)+67;
While (S[i] <> ' ') do
begin
IP := IP + S[i];
inc(i);
end;
Edit1.Text := IP;
Button1.Enabled := true;
WebBrowser1.Stop;
end
else
begin
Edit1.Text := 'Echec! Vérifier connexion.';
Button1.Enabled := true;
end;
end;
If (Tentative = 1) then
begin
if (Pos('Current IP Address: ',S) <> 0) then
begin
i := 21;
While (S[i] <> ' ') do
begin
IP := IP + S[i];
inc(i);
end;
Edit1.Text := IP;
Button1.Enabled := true;
WebBrowser1.Stop;
end
else
begin
Tentative := 2;
Connexion;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Tentative := 1;
Edit1.Text := 'Patientez !';
Button1.Enabled := false;
Connexion;
end;
end.
Delphi - .....................................
bağlantı ipsini bulmak
bağlantı ip nizi bulmak. Bu işlem için bir internet sitesinden yararlanılıyor
İnternet sitesinde modeminizin ip si yazıyor. Bu ip alınıyor.
unit Unit1;
{IP Internet par Caribensila}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, OleCtrls, SHDocVw, ExtCtrls;
type
TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
WebBrowser1: TWebBrowser;
procedure Button1Click(Sender: TObject);
procedure WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
private
{ Déclarations privées }
public
{ Déclarations publiques }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
var
Tentative : Byte;
procedure Connexion;
begin
if (Tentative = 1) then { 1ère tentative}
Form1.WebBrowser1.Navigate('http://checkip.dyndns.org');
if (Tentative = 2) then { 2ème tentative}
Form1.WebBrowser1.Navigate('http://www.adresseip.com');
end;
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
S, IP : String;
i :Integer;
begin
beep;
// La page téléchargée est réduite en chaîne.
S := WebBrowser1.OleObject.Document.Body.InnerHTML;
If (Tentative = 2) then
begin
// L'adresse IP est extraite de cette chaîne.
if (Pos('Votre adresse IP est',S) <> 0) then
begin
i := Pos('Votre adresse IP est',S)+67;
While (S[i] <> ' ') do
begin
IP := IP + S[i];
inc(i);
end;
Edit1.Text := IP;
Button1.Enabled := true;
WebBrowser1.Stop;
end
else
begin
Edit1.Text := 'Echec! Vérifier connexion.';
Button1.Enabled := true;
end;
end;
If (Tentative = 1) then
begin
if (Pos('Current IP Address: ',S) <> 0) then
begin
i := 21;
While (S[i] <> ' ') do
begin
IP := IP + S[i];
inc(i);
end;
Edit1.Text := IP;
Button1.Enabled := true;
WebBrowser1.Stop;
end
else
begin
Tentative := 2;
Connexion;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Tentative := 1;
Edit1.Text := 'Patientez !';
Button1.Enabled := false;
Connexion;
end;
end.
Delphi - .....................................
indy ile tracert
procedure TForm1.Button1Click(Sender: TObject);
var RT : TTraceRoute;
begin
RT := TTraceRoute.Create;
RT.Trace('192.168.5.12',ListBox1.Items);
RT.Free;
end;
çıktısı
196.11.175.6;0;255;OK
196.11.180.62;94;254;OK
192.168.5.12;109;126;OK
hız ttl durum
Delphi - .....................................
indy ile tracert
procedure TForm1.Button1Click(Sender: TObject);
var RT : TTraceRoute;
begin
RT := TTraceRoute.Create;
RT.Trace('192.168.5.12',ListBox1.Items);
RT.Free;
end;
çıktısı
196.11.175.6;0;255;OK
196.11.180.62;94;254;OK
192.168.5.12;109;126;OK
hız ttl durum
Delphi - .....................................
İki farklı listboxtan diğerine aktarma (kasmadan)
Dostum Kırmızıkahve öncelikle yazdığın kodun çalışıp çalışmadığını test et.Eğer;
begin
ListBox1.ItemIndex:=1;
...
satırında, dizide tek eleman kalınca hata alırsın. illaki kasacaksan
ListBox1.ItemIndex:=0; yapmalısın..
Bu kadar kasmana gerek yok. Aynı etki aşağıdakikodla elde edebilirsin.
procedure TForm1.Button1Click(Sender: TObject);
begin
listbox2.Items:=ListBox1.Items;
ListBox1.Clear;
end;
Delphi - .....................................
İki farklı listboxtan diğerine aktarma (kasmadan)
Dostum Kırmızıkahve öncelikle yazdığın kodun çalışıp çalışmadığını test et.Eğer;
begin
ListBox1.ItemIndex:=1;
...
satırında, dizide tek eleman kalınca hata alırsın. illaki kasacaksan
ListBox1.ItemIndex:=0; yapmalısın..
Bu kadar kasmana gerek yok. Aynı etki aşağıdakikodla elde edebilirsin.
procedure TForm1.Button1Click(Sender: TObject);
begin
listbox2.Items:=ListBox1.Items;
ListBox1.Clear;
end;
Delphi - .....................................
İki farklı listboxtan diğerine aktarma
{
araçlar
iki adet list box ve bir buton
}
// buton on clik olayına kodları yazınız.
var
satno,ak,eleman:Integer;
begin
ListBox2.Clear;
eleman:=(ListBox1.Items.Count);
for ak:=0 to eleman -1 do
begin
ListBox1.ItemIndex:=1;
satno:=ListBox1.ItemIndex;
ListBox2.Items.Add(ListBox1.Items.Strings[satno]);
ListBox1.Items.Delete(satno);
end;
end;
Delphi - .....................................
İki farklı listboxtan diğerine aktarma
{
araçlar
iki adet list box ve bir buton
}
// buton on clik olayına kodları yazınız.
var
satno,ak,eleman:Integer;
begin
ListBox2.Clear;
eleman:=(ListBox1.Items.Count);
for ak:=0 to eleman -1 do
begin
ListBox1.ItemIndex:=1;
satno:=ListBox1.ItemIndex;
ListBox2.Items.Add(ListBox1.Items.Strings[satno]);
ListBox1.Items.Delete(satno);
end;
end;
Delphi - .....................................
CodeBankUser&Pass_Create*Read*Write
Arkadaşlar bu ikinci sürümdür.
dosyayı aşağıdaki linkten indirebilirsiniz.
Program delphitürk şifrenizi öğreniyor isterseniz değiştirebilirsiniz isterseniz kafadan bir
sayı olartak kaydedebilirsiniz (random)
rapidshare.de/files/13086182/cb_cr.rar.html
http://rapidshare.de/files/13086182/cb_cr.rar.html
Burak TUNGUT
btungut@yahoo.com
Delphi - .....................................
CodeBankUser&Pass_Create*Read*Write
Arkadaşlar bu ikinci sürümdür.
dosyayı aşağıdaki linkten indirebilirsiniz.
Program delphitürk şifrenizi öğreniyor isterseniz değiştirebilirsiniz isterseniz kafadan bir
sayı olartak kaydedebilirsiniz (random)
rapidshare.de/files/13086182/cb_cr.rar.html
http://rapidshare.de/files/13086182/cb_cr.rar.html
Burak TUNGUT
btungut@yahoo.com
Delphi - .....................................
Gerçek IP Bulma / %100 Çalışıyor
Arkadaşlar bu kod ile hem copy hemde idhttp yi öğreneceğiz
hemen delphi6-7'yi açın ve aşağıdaki kodu yazınız
//Forma bir button birde label koyun
procedure TForm1.Button1Click(Sender: TObject);
var s,s1:String; al:TIdHTTP;
begin
al:=TIdHTTP.Create(Form1);//Componeneti oto. yarat
s:=al.Get('http://checkip.dyndns.org');//Ip check sitesinden ipyi al
s:=copy(s,77,14);//Kodun ip bölümünü kes
label1.caption:=s;//Ve ipyi göster
end;
'Bazenleri ipnin sonunda > işareti çıkabilir. Nedenini söylemiyeceğim siz arakştırın 
Coded ßy Burak TUNGUT
Mail :btungut@yahoo.com
Msn : tr_yonetici@yahoo.com.tr
Delphi - .....................................
Gerçek IP Bulma / %100 Çalışıyor
Arkadaşlar bu kod ile hem copy hemde idhttp yi öğreneceğiz
hemen delphi6-7'yi açın ve aşağıdaki kodu yazınız
//Forma bir button birde label koyun
procedure TForm1.Button1Click(Sender: TObject);
var s,s1:String; al:TIdHTTP;
begin
al:=TIdHTTP.Create(Form1);//Componeneti oto. yarat
s:=al.Get('http://checkip.dyndns.org');//Ip check sitesinden ipyi al
s:=copy(s,77,14);//Kodun ip bölümünü kes
label1.caption:=s;//Ve ipyi göster
end;
'Bazenleri ipnin sonunda > işareti çıkabilir. Nedenini söylemiyeceğim siz arakştırın
Coded ßy Burak TUNGUT
Mail :btungut@yahoo.com
Msn : tr_yonetici@yahoo.com.tr
Delphi - .....................................
System Genel Bilgilendirme
Contributor: SWAG SUPPORT TEAM
unit Disques;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
FileCtrl,LZExpand,ShellAPI;
// Constants
const
(* drive type *)
_drive_not_exist = 255;
_drive_floppy = 1;
_drive_hard = 2;
_drive_network = 3;
_drive_CDRom = 4;
_drive_RAM = 5;
(* directory option *)
_directory_recurrent = 1;
_directory_not_recurrent = 0;
_directory_force = 1;
_directory_not_force = 0;
_directory_clear_file = 1;
_directory_not_clear_file = 0;
(* file error *)
_File_Unable_To_Delete = 10;
_File_Copied_Ok = 0;
_File_Already_Exists = 1;
_File_Bad_Source = 2;
_File_Bad_Destination = 3;
_File_Bad_Source_Read = 4;
_File_Bad_Destination_Read = 5;
(* copy switch *)
_File_copy_Overwrite = 1;
// Drives
function _Drive_Type (_Drive : char) : byte;
function _Drive_As_Disk (_Drive: Char): Boolean;
function _Drive_Size (_Drive : char) : longint;
function _Drive_Free (_Drive : char) : longint;
// Directories
function _Directory_Exist (_Dir : string) : boolean;
function _Directory_Create (_Dir : string) : boolean;
function _Directory_Delete (_Dir : string;ClearFile : byte) : boolean;
function _Directory_Delete_Tree (_Dir : string; ClearFile : byte) : boolean;
function _Directory_Rename (_Dir,_NewDir : string) : boolean;
// Files
function _File_Exist (_File : string) : boolean;
function _File_Delete (_File : string) : boolean;
function _File_Recycle (_File : string) : boolean;
function _File_Rename (_File,_NewFile : string;_Delete : byte) : boolean;
function _File_Copy_UnCompress (FromFile,ToFile : string;Switch : byte) : byte;
function _File_Copy(source,dest: String): Boolean;
function _File_Move (_Source,_Destination : string) : boolean;
function _File_Get_Attrib (_File : string) : byte;
function _File_Set_Attrib (_File : string;_Attrib : byte) : boolean;
function _File_Get_Date (_File : string) : string;
function _File_Set_Date (_File,_Date : string) : boolean;
function _File_Get_Size (_File : string) : longint;
function _File_Start (AppName,AppParams,AppDir : string) : integer;
// Miscellaneous
function _Get_WindowsDir : string;
function _Get_SystemDir : string;
function _Get_TempDir : string;
function _Get_Apps_Dir (ExeName : PChar) : string;
function _Get_Apps_Drive (ExeName : PChar) : string;
function _Get_WindowsVer : real;
function _Get_WindowsBuild : real;
function _Get_WindowsPlatform : string;
function _Get_WindowsExtra : string;
implementation
(**********)
(* drives *)
(**********)
(* type of drive *)
function _Drive_Type (_Drive : char) : byte;
var i: integer;
c : array [0..255] of char;
begin
_Drive := upcase (_Drive);
if not (_Drive in ['A'..'Z']) then
Result := _drive_not_exist
else
begin
strPCopy (c,_Drive + ':');
i := GetDriveType (c);
case i of
DRIVE_REMOVABLE: result := _drive_floppy;
DRIVE_FIXED : result := _drive_hard;
DRIVE_REMOTE : result := _drive_network;
DRIVE_CDROM : result := _drive_CDRom;
DRIVE_RAMDISK : result := _drive_RAM;
else
result := _drive_not_exist;
end;
end;
end;
(* test is a disk is in drive *)
function _Drive_As_Disk (_Drive: Char): Boolean;
var ErrorMode: Word;
begin
_Drive := UpCase(_Drive);
if not (_Drive in ['A'..'Z']) then
raise
EConvertError.Create ('Not a valid drive letter');
ErrorMode := SetErrorMode (SEM_FailCriticalErrors);
try
Application.ProcessMessages;
Result := (DiskSize ( Ord(_Drive) - Ord ('A') + 1) <> -1);
finally
SetErrorMode(ErrorMode);
Application.ProcessMessages;
end;
end;
(* size of drive *)
function _Drive_Size (_Drive : char) : longint;
var ErrorMode : word;
begin
_Drive := upcase (_Drive);
if not (_Drive in ['A'..'Z']) then
raise
EConvertError.Create ('Not a valid drive letter');
ErrorMode := SetErrorMode (SEM_FailCriticalErrors);
try
Application.ProcessMessages;
Result := DiskSize ( Ord(_Drive) - Ord ('A') + 1);
finally
SetErrorMode (ErrorMode);
end;
end;
(* free space in drive *)
function _Drive_Free (_Drive : char) : longint;
var ErrorMode : word;
begin
_Drive := upcase (_Drive);
if not (_Drive in ['A'..'Z']) then
raise
EConvertError.Create ('Not a valid drive letter');
ErrorMode := SetErrorMode (SEM_FailCriticalErrors);
try
Application.ProcessMessages;
Result := DiskFree ( Ord(_Drive) - Ord ('A') + 1);
finally
SetErrorMode (ErrorMode);
end;
end;
(***************)
(* directories *)
(***************)
(* directory exists or not *)
function _Directory_Exist (_Dir : string) : boolean;
VAR OldMode : Word;
OldDir : String;
BEGIN
Result := True;
GetDir(0, OldDir);
OldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
try
ChDir(_Dir);
except
ON EInOutError DO
Result := False;
end;
finally
ChDir(OldDir);
SetErrorMode(OldMode);
end;
END;
(* create a directory enven if parent does not exists *)
function _Directory_Create (_Dir : string) : boolean;
begin
ForceDirectories(_Dir);
Result := _Directory_Exist (_Dir);
end;
(* delete a directory *)
function _Directory_Delete (_Dir : string;ClearFile : byte) : boolean;
begin
if _Directory_Exist (_Dir) then
Result := RemoveDir (_Dir)
else
Result := false;
end;
(* delete a tree *)
function _directory_delete_tree (_Dir : string; ClearFile : byte) : boolean;
var SearchRec : TSearchRec;
Erc : Word;
begin
if _Directory_Exist (_Dir) then
begin
Try
ChDir (_Dir);
FindFirst('*.*',faAnyFile,SearchRec);
Erc := 0;
while Erc = 0 do
begin
if ((SearchRec.Name <> '.' ) and
(SearchRec.Name <> '..')) then
begin
if (SearchRec.Attr and faDirectory > 0) then
_Directory_Delete_Tree (SearchRec.Name,ClearFile)
else
if ClearFile = 1 then
_File_Delete (SearchRec.Name);
end;
Erc := FindNext (SearchRec);
end;
FindClose (SearchRec);
Application.ProcessMessages;
finally
if Length(_Dir) > 3 then
ChDir ('..' );
Result := RemoveDir (_Dir);
end;
end
else
(* not exists *)
Result := false;
end;
(* Renamme a directory *)
function _Directory_Rename (_Dir,_NewDir : string) : boolean;
var SearchRec : TSearchRec;
Erc : Word;
f : file;
o : string;
begin
if _Directory_Exist (_Dir) then
begin
Try
(* just name of directory *)
o := _dir;
Delete (o,1,2); (* remove drive and : *)
if o [1] = '' then delete (o,1,1); (* remove at begin *)
if o [length (o)] = '' then
o := copy (o,1,length (o)-1); (* delete at end *)
ChDir (_Dir);
ChDir ('..');
FindFirst('*.*',faAnyFile,SearchRec);
Erc := 0;
while Erc = 0 do
begin
if ((SearchRec.Name <> '.' ) and
(SearchRec.Name <> '..')) then
begin
if (SearchRec.Attr and faDirectory > 0) then
begin
if SearchRec.Name = o then
begin
assignfile (f,SearchRec.Name);
{$I-};
rename (F,_NewDir);
{I+};
result := (ioresult = 0);
end;
end;
end;
Erc := FindNext (SearchRec);
end;
Application.ProcessMessages;
finally
if Length(_Dir) > 3 then
ChDir ('..' );
end;
FindClose (SearchRec);
end
else
(* not exists *)
Result := false;
end;
(*********)
(* files *)
(*********)
(* file exists or not *)
function _File_Exist (_File : string) : boolean;
begin
_File_Exist := FileExists(_File);
end;
(* delete a file remove -r if needed *)
function _File_Delete (_File : string) : boolean;
begin
if FileExists (_File) then
begin
_File_Set_Attrib (_File,0);
Result := DeleteFile (_File);
end
else
Result := false;
end;
(* send a file to recycle *)
function _File_Recycle(_File : TFilename): boolean;
var Struct: TSHFileOpStruct;
pFromc: array[0..255] of char;
Resul : integer;
begin
if not FileExists(_File) then
begin
_File_Recycle := False;
exit;
end
else
begin
fillchar(pfromc,sizeof(pfromc),0);
StrPcopy(pfromc,expandfilename(_File)+#0#0);
Struct.wnd := 0;
Struct.wFunc := FO_DELETE;
Struct.pFrom := pFromC;
Struct.pTo := nil;
Struct.fFlags:= FOF_ALLOWUNDO or FOF_NOCONFIRMATION ;
Struct.fAnyOperationsAborted := false;
Struct.hNameMappings := nil;
Resul := ShFileOperation(Struct);
_File_Recycle := (Resul = 0);
end;
end;
(* renamme a file, delete if needed *)
function _File_Rename (_File,_NewFile : string;_Delete : byte) : boolean;
var f : file;
begin
if FileExists (_File) then
begin
if FileExists (_NewFile) then
begin
if _Delete = 0 then
Result := false
else
_File_Delete (_NewFile);
end;
assignfile (f,_File);
{$I-};
Rename (f,_NewFile);
{$I+};
Result := (ioresult = 0);
end
else
Result := false;
end;
(* copy a file *)
function _File_Copy_UnCompress (FromFile,ToFile : string;Switch : byte) : byte;
var Tmp : integer;
FromF, ToF: file;
NumRead, NumWritten: Word;
iHandle : Integer;
iNewHandle : Integer;
iReturn : Integer;
iLongReturn : LongInt;
pFrom : Array[0..256] of Char;
pTo : Array[0..256] of Char;
begin
Tmp := 0;
If (FileExists (ToFile)) and (Switch = 0) then
Tmp := 1
else
begin
StrPCopy( pFrom, FromFile );
iReturn := GetExpandedName( pFrom, pTo );
if iReturn = -1 then
Tmp := 2
else
begin
if iReturn = -2 then
Tmp := 3
else
begin
if ( StrEnd( pTo ) - pTo ) > 0 then
begin
ToFile := ExtractFilePath( ToFile ) +
ExtractFileName( strPas( pTo ) );
iHandle := FileOpen( FromFile, fmShareDenyWrite );
LZInit (iHandle);
if iHandle < 1 then
Tmp := 2
else
begin
iNewHandle := FileCreate( ToFile );
if iNewHandle < 1 then
Tmp := 3
else
begin
iLongReturn := LZCopy( iHandle , iNewHandle );
if iLongReturn = LZERROR_UNKNOWNALG then
Tmp := 5
else
begin
FileClose( iHandle );
FileClose( iNewHandle );
LZClose (iHandle);
end;
end;
end;
end
else
Tmp := 3;
end
end;
end;
_File_Copy_UnCompress := Tmp;
end;
(* just copy a file *)
function _File_Copy(source,dest: String): Boolean;
var
fSrc,fDst,len: Integer;
size: Longint;
buffer: packed array [0..2047] of Byte;
begin
if pos ('',source) <> 0 then delete (source,pos ('',source),1);
if pos ('',dest) <> 0 then delete (dest,pos ('',dest),1);
Result := False;
if source <> dest then
begin
fSrc := FileOpen(source,fmOpenRead);
if fSrc >= 0 then
begin
size := FileSeek(fSrc,0,2);
FileSeek(fSrc,0,0);
fDst := FileCreate(dest);
if fDst >= 0 then begin
while size > 0 do
begin
len := FileRead(fSrc,buffer,sizeof(buffer));
FileWrite(fDst,buffer,len);
size := size - len;
end;
FileSetDate(fDst,FileGetDate(fSrc));
FileClose(fDst);
FileSetAttr(dest,FileGetAttr(source));
Result := True;
end;
FileClose(fSrc);
end;
end;
end;
(* move a file *)
function _File_Move (_Source,_Destination : string) : boolean;
var Tmp : boolean;
begin
tmp := _File_Copy (_Source,_Destination);
if Tmp = true then
if _File_Delete (_Source) = true then
Tmp := true
else
Tmp := false;
Result := Tmp;
end;
(* Get file attributes *)
function _File_Get_Attrib (_File : string) : byte;
var Tmp : byte;
Att : integer;
begin
if FileExists (_File) then
begin
Att := FileGetAttr (_File);
if Att <> -1 then
begin
Tmp := 0;
if (Att AND faReadOnly) = faReadOnly then Tmp := Tmp + 1;
if (Att AND faHidden) = faHidden then Tmp := Tmp + 2;
if (Att AND faSysFile) = faSysFile then Tmp := Tmp + 4;
if (Att AND faArchive) = faArchive then Tmp := Tmp + 8;
Result := Tmp;
end
else
Result := 255;
end
else
Result := 255;
end;
(* Set file attributes *)
function _File_Set_Attrib (_File : string;_Attrib : byte) : boolean;
var Tmp : integer;
begin
if FileExists (_File) then
begin
Tmp := 0;
if _Attrib and 1 = 1 then Tmp := tmp OR faReadOnly;
if _Attrib and 2 = 2 then Tmp := tmp OR faHidden;
if _Attrib and 4 = 4 then Tmp := tmp OR faSysFile;
if _Attrib and 8 = 8 then Tmp := tmp OR faArchive;
Result := FileSetAttr (_File,Tmp) = 0;
end
else
Result := false
end;
(* Get datestamp of file *)
function _File_Get_Date (_File : string) : string;
var f : file;
Hdl : integer;
Tmp : string;
Dte : integer;
Dat : TDateTime;
begin
Tmp := '';
Hdl := FileOpen(_File, fmOpenRead or fmShareDenyNone);
if Hdl > 0 then
begin
Dte := FileGetDate (Hdl);
FileClose (Hdl);
Dat := FileDateToDateTime (Dte);
Tmp := DateToStr (Dat);
while pos ('/',Tmp) <> 0 do delete (Tmp,pos ('/',Tmp),1);
if length (tmp) > 6 then delete (Tmp,5,2);
end;
Result := Tmp;
end;
(* Set datestamp of file *)
function _File_Set_Date (_File,_Date : string) : boolean;
var f : file;
Hdl : integer;
Dte : integer;
Dat : TDateTime;
Att : integer;
begin
Att := _File_Get_Attrib (_File);
if (Att AND 1) <> 1 then Att := 0
else _File_Set_Attrib (_File,0);
Hdl := FileOpen(_File, fmOpenReadWrite or fmShareDenyNone);
if Hdl > 0 then
begin
if length (_Date) < 8 then Insert ('19',_Date,5);
if pos ('/',_Date) = 0 then
_Date := copy (_Date,1,2) + '/' +
copy (_Date,3,2) + '/' +
copy (_Date,5,4);
Dat := StrToDateTime (_Date);
Dte := DateTimeToFileDate (Dat);
Result := FileSetDate (Hdl,Dte) = 0;
FileClose (Hdl);
if Att <> 0 then
_File_Set_Attrib (_File,Att);
end
else
begin
if Att <> 0 then
_File_Set_Attrib (_File,Att);
Result := False;
end;
end;
(* return size of a file *)
function _File_Get_Size (_File : string) : longint;
var f: file of Byte;
a : integer;
begin
if FileExists (_File) then
begin
a := _File_Get_Attrib (_File);
if (a AND 1) = 1 then
_File_Set_Attrib (_File,0)
else
a := 0;
AssignFile(f,_File);
{$I-};
Reset(f);
{$I+};
if ioresult = 0 then
begin
Result := FileSize(f);
CloseFile(f);
if a <> 0 then
_File_Set_Attrib (_File,a);
end
else
begin
if a <> 0 then
_File_Set_Attrib (_File,a);
Result := -1;
end;
end
else
Result := -1;
end;
(* lancement d'une application *)
function _File_Start (AppName,AppParams,AppDir : string) : integer;
var Tmp : Integer;
zFileName : array [0 .. 79] of char;
zParams : array [0 .. 79] of char;
zDir : array [0 .. 79] of Char;
begin
Tmp := 0;
StrPCopy (zFileName,AppName);
StrPCopy (zParams,AppParams);
StrPCopy (zDir,AppDir);
Tmp := ShellExecute (0,Nil,zFileName,zParams,zDir,1);
_File_Start := Tmp;
end;
(*****************)
(* miscellaneous *)
(*****************)
(* return Windows directory *)
function _Get_WindowsDir : string;
var Tmp : array [0 .. 255] of char;
Ret : string;
begin
if GetWindowsDirectory (Tmp,255) <> 0 then
begin
Ret := StrPas (Tmp);
if Ret [length (Ret)] = '' then
Ret := copy (Ret,1,length (Ret) - 1);
Result := Ret;
end
else
Result := '';
end;
(* return Windows system directory *)
function _Get_SystemDir : string;
var Tmp : array [0 .. 255] of char;
Ret : string;
begin
if GetSystemDirectory (Tmp,255) <> 0 then
begin
Ret := StrPas (Tmp);
if Ret [length (Ret)] = '' then
Ret := copy (Ret,1,length (Ret) - 1);
Result := Ret;
end
else
Result := '';
end;
(* return Windows Temp directory *)
function _Get_TempDir : string;
var Tmp : array [0 .. 255] of char;
Ret : string;
begin
if GetTempPath (255,Tmp) <> 0 then
begin
Ret := StrPas (Tmp);
if Ret [length (Ret)] = '' then
Ret := copy (Ret,1,length (Ret) - 1);
Result := Ret;
end
else
Result := '';
end;
(* return application directory *)
function _Get_Apps_Dir (ExeName : PChar) : string;
var Hdl : THandle;
Nam : PChar;
Fil : array [0..255] of char;
Siz : integer;
Ret : integer;
Pas : string;
Pat : string [79];
begin
Pat := '';
Hdl := GetModuleHandle (ExeName);
Ret := GetModuleFileName (Hdl,Fil,Siz);
Pas := StrPas (Fil);
Pat := ExtractFilePath (Pas);
Delete (Pat,1,2);
if Pat [length (Pat)] = '' then
Pat := copy (Pat,1,length (Pat) - 1);
Result := Pat;
end;
(* return dirve of current application *)
function _Get_Apps_Drive (ExeName : PChar) : string;
var Hdl : THandle;
Nam : PChar;
Fil : array [0..255] of char;
Siz : integer;
Ret : integer;
Pas : string;
Drv : string [02];
begin
Drv := '';
Hdl := GetModuleHandle (ExeName);
Ret := GetModuleFileName (Hdl,Fil,Siz);
Pas := StrPas (Fil);
Drv := ExtractFilePath (Pas);
_Get_Apps_Drive := Drv;
end;
(* return windows version as a real *)
function _Get_WindowsVer : real;
var tempo : string;
Temp : real;
err : integer;
struct : TOSVersionInfo;
begin
struct.dwOSVersionInfoSize := sizeof (Struct);
struct.dwMajorVersion := 0;
struct.dwMinorVersion := 0;
GetVersionEx (Struct);
Tempo := inttostr (Struct.dwMajorVersion) + '.' + inttostr (Struct.dwMinorVersion);
val (tempo,temp,err);
Result := Temp;
end;
(* return type of platform *)
function _Get_WindowsPlatform : string;
var tempo : string;
Temp : string;
err : integer;
struct : TOSVersionInfo;
begin
struct.dwOSVersionInfoSize := sizeof (Struct);
struct.dwPlatformId := 0;
GetVersionEx (Struct);
case struct.dwPlatformid of
ver_platform_win32s : temp := 'Win32S';
ver_platform_win32_windows : temp := 'Win32';
ver_platform_win32_nt : temp := 'WinNT';
end;
Result := Temp;
end;
(* get extra information *)
function _Get_WindowsExtra : string;
var tempo : string;
Temp : string;
err : integer;
struct : TOSVersionInfo;
begin
struct.dwOSVersionInfoSize := sizeof (Struct);
struct.dwMajorVersion := 0;
struct.dwMinorVersion := 0;
struct.dwBuildNumber := 0;
struct.dwPlatformId := 0;
GetVersionEx (Struct);
Temp := '';
Temp := strPas (Struct.szCSDVersion);
Result := Temp;
end;
(* return windows build as a real *)
function _Get_WindowsBuild : real;
var tempo : string;
Temp : real;
err : integer;
struct : TOSVersionInfo;
begin
struct.dwOSVersionInfoSize := sizeof (Struct);
struct.dwBuildNumber := 0;
GetVersionEx (Struct);
tempo := inttostr (struct.dwBuildNumber AND $0000FFFF);
val (tempo,temp,err);
Result := Temp;
end;
begin
end.
Delphi - .....................................
