Sanal Disk Oluşturun !!!!!!
Delphi ile istediğiniz bir klasörü bir disk sürücü olarak gösterebilirsiniz
Evet doğru. İşinize kesin yarar....
Arkadaşlar ftp programınızı biraz geliştirim GoogleDisk gibi bir program
yazabilirsiniz.
Böylece daha kullanışlı fpt programları yazabilirsiniz.
Edit1 içine diskin adını yazın(D,E,F,...gibi)
Edit2 içine bu ismin hangi klasörü temsil edeceğini yazın(C:Downloads,...gibi)
button1 deki kod sanal disk oluşturmak için
button2 deki kod sanal diski kaldırmak için kullanılıyor.
Oluşturduğunuz disk bilgisayarım simgesine hemen geliyor....
Procedure ListDrives(DrivesStrs:TStrings);
Var
Drive: Char;
DriveLetter: String[4];
sDriveType: String;
Begin
For Drive := 'A' To 'Z' Do
Begin
DriveLetter := Drive + ':';
sDriveType := '';
Case GetDriveType(PChar(Drive + ':')) Of
DRIVE_REMOVABLE: sDriveType := 'Floppy';
DRIVE_FIXED: sDriveType := 'Fixed';
DRIVE_REMOTE: sDriveType := 'Network';
DRIVE_CDROM: sDriveType := 'CD-ROM';
DRIVE_RAMDISK: sDriveType := 'RAM Disk';
End;
If sDriveType <> '' Then
Begin
sDriveType := sDriveType + ' Drive ';
DrivesStrs.Add(Format('Drive %s:', [Drive])+' - '+sDriveType);
End;
End;
End;
Procedure UnmapVirtualDrive(Const Drive:Char);
Begin
If (GetDriveType(PChar(Drive+':'))<>DRIVE_FIXED) Then
Raise Exception.Create('['+Drive+':] Is not a Virtual drive');
WinExec(PChar('subst /d '+Drive+': '), SW_HIDE);
Sleep(250); //give some time for the execution
If (GetDriveType(PChar(Drive+':'))>1) Then
Raise Exception.Create('Could not unmap Virtual drive ['+Drive+':]')
End;
Function MapVirtualDrive(Const Drive:Char; Const Path:String):Boolean;
Var DType:Integer;
Begin
DType:=GetDriveType(PChar(Drive+':'));
If (DType=DRIVE_FIXED) Then
Begin
If (MessageDlg('Drive ['+Drive+':] already exists, Do you want to try And replace it?', mtWarning, [mbYes, mbNo, mbCancel], 0)=mrYes) Then
UnmapVirtualDrive(Drive)
End
Else If (DType>1) Then
Raise Exception.Create('Drive '+Drive+': cannot be maped (drive not overwritable)');
WinExec(PChar('subst '+Drive+': '+Path), SW_HIDE);
Sleep(250); //give some time for the execution
Application.ProcessMessages;
Result:=GetDriveType(PChar(Drive+':'))=DRIVE_FIXED
End;
procedure TForm1.Button1Click(Sender: TObject);
begin
If (MapVirtualDrive(Edit1.Text[1], Edit2.Text)) Then
ShowMessage('Virtual Drive ['+Edit1.Text+'] created')
Else
ShowMessage('Could not map Virtual Drive ['+Edit1.Text+']')
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
UnmapVirtualDrive(Edit1.Text[1]);
ShowMessage(Edit1.Text+' unmaped succesful')
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
ListDrives(Memo1.Lines);
end;
Delphi - .....................................
Sanal Disk Oluşturun !!!!!!
Delphi ile istediğiniz bir klasörü bir disk sürücü olarak gösterebilirsiniz
Evet doğru. İşinize kesin yarar....
Arkadaşlar ftp programınızı biraz geliştirim GoogleDisk gibi bir program
yazabilirsiniz.
Böylece daha kullanışlı fpt programları yazabilirsiniz.
Edit1 içine diskin adını yazın(D,E,F,...gibi)
Edit2 içine bu ismin hangi klasörü temsil edeceğini yazın(C:Downloads,...gibi)
button1 deki kod sanal disk oluşturmak için
button2 deki kod sanal diski kaldırmak için kullanılıyor.
Oluşturduğunuz disk bilgisayarım simgesine hemen geliyor....
Procedure ListDrives(DrivesStrs:TStrings);
Var
Drive: Char;
DriveLetter: String[4];
sDriveType: String;
Begin
For Drive := 'A' To 'Z' Do
Begin
DriveLetter := Drive + ':';
sDriveType := '';
Case GetDriveType(PChar(Drive + ':')) Of
DRIVE_REMOVABLE: sDriveType := 'Floppy';
DRIVE_FIXED: sDriveType := 'Fixed';
DRIVE_REMOTE: sDriveType := 'Network';
DRIVE_CDROM: sDriveType := 'CD-ROM';
DRIVE_RAMDISK: sDriveType := 'RAM Disk';
End;
If sDriveType <> '' Then
Begin
sDriveType := sDriveType + ' Drive ';
DrivesStrs.Add(Format('Drive %s:', [Drive])+' - '+sDriveType);
End;
End;
End;
Procedure UnmapVirtualDrive(Const Drive:Char);
Begin
If (GetDriveType(PChar(Drive+':'))<>DRIVE_FIXED) Then
Raise Exception.Create('['+Drive+':] Is not a Virtual drive');
WinExec(PChar('subst /d '+Drive+': '), SW_HIDE);
Sleep(250); //give some time for the execution
If (GetDriveType(PChar(Drive+':'))>1) Then
Raise Exception.Create('Could not unmap Virtual drive ['+Drive+':]')
End;
Function MapVirtualDrive(Const Drive:Char; Const Path:String):Boolean;
Var DType:Integer;
Begin
DType:=GetDriveType(PChar(Drive+':'));
If (DType=DRIVE_FIXED) Then
Begin
If (MessageDlg('Drive ['+Drive+':] already exists, Do you want to try And replace it?', mtWarning, [mbYes, mbNo, mbCancel], 0)=mrYes) Then
UnmapVirtualDrive(Drive)
End
Else If (DType>1) Then
Raise Exception.Create('Drive '+Drive+': cannot be maped (drive not overwritable)');
WinExec(PChar('subst '+Drive+': '+Path), SW_HIDE);
Sleep(250); //give some time for the execution
Application.ProcessMessages;
Result:=GetDriveType(PChar(Drive+':'))=DRIVE_FIXED
End;
procedure TForm1.Button1Click(Sender: TObject);
begin
If (MapVirtualDrive(Edit1.Text[1], Edit2.Text)) Then
ShowMessage('Virtual Drive ['+Edit1.Text+'] created')
Else
ShowMessage('Could not map Virtual Drive ['+Edit1.Text+']')
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
UnmapVirtualDrive(Edit1.Text[1]);
ShowMessage(Edit1.Text+' unmaped succesful')
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
ListDrives(Memo1.Lines);
end;
Delphi - .....................................
Win Environment bilgilerini almak ve değiştirmek
function GetUserEnvironmentVariable(const name: string): string;
var
rv: DWORD;
begin
with TRegistry.Create do
try
RootKey := HKEY_CURRENT_USER;
OpenKey('Environment', False);
result := ReadString(name);
finally
Free
end
end;
procedure SetUserEnvironmentVariable(const name, value: string);
var
rv: DWORD;
begin
with TRegistry.Create do
try
RootKey := HKEY_CURRENT_USER;
OpenKey('Environment', False);
WriteString(name, value);
SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, LParam
(PChar('Environment')), SMTO_ABORTIFHUNG, 5000, rv);
finally
Free
end
end;
The next two procedures read and write environment variables for the
system and thus affect all users.
function GetSystemEnvironmentVariable(const name: string): string;
var
rv: DWORD;
begin
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('SYSTEMCurrentControlSetControlSession ' +
'ManagerEnvironment', False);
result := ReadString(name);
finally
Free
end
end;
// Modified from
// http://www.delphiabc.com/TipNo.asp?ID=117
// The original article did not include the space in
// "Session Manager" which caused the procedure to fail.
procedure SetSystemEnvironmentVariable(const name, value: string);
var
rv: DWORD;
begin
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('SYSTEMCurrentControlSetControlSession ' +
'ManagerEnvironment', False);
WriteString(name, value);
SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, LParam
(PChar('Environment')), SMTO_ABORTIFHUNG, 5000, rv);
finally
Free
end
end;
Delphi - .....................................
Win Environment bilgilerini almak ve değiştirmek
function GetUserEnvironmentVariable(const name: string): string;
var
rv: DWORD;
begin
with TRegistry.Create do
try
RootKey := HKEY_CURRENT_USER;
OpenKey('Environment', False);
result := ReadString(name);
finally
Free
end
end;
procedure SetUserEnvironmentVariable(const name, value: string);
var
rv: DWORD;
begin
with TRegistry.Create do
try
RootKey := HKEY_CURRENT_USER;
OpenKey('Environment', False);
WriteString(name, value);
SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, LParam
(PChar('Environment')), SMTO_ABORTIFHUNG, 5000, rv);
finally
Free
end
end;
The next two procedures read and write environment variables for the
system and thus affect all users.
function GetSystemEnvironmentVariable(const name: string): string;
var
rv: DWORD;
begin
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('SYSTEMCurrentControlSetControlSession ' +
'ManagerEnvironment', False);
result := ReadString(name);
finally
Free
end
end;
// Modified from
// http://www.delphiabc.com/TipNo.asp?ID=117
// The original article did not include the space in
// "Session Manager" which caused the procedure to fail.
procedure SetSystemEnvironmentVariable(const name, value: string);
var
rv: DWORD;
begin
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('SYSTEMCurrentControlSetControlSession ' +
'ManagerEnvironment', False);
WriteString(name, value);
SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, LParam
(PChar('Environment')), SMTO_ABORTIFHUNG, 5000, rv);
finally
Free
end
end;
Delphi - .....................................
Cpu hakkında ayrıntılı bilgi
Question/Problem/Abstract:
Sometime u need to know some information about the CPU
like: brand id, factory speed, wich instruction set supported etc.
If so, than u can use this code.
2002 by -=LTi=-
Answer:
//Sometime u need to know some information about the CPU
//like: brand id, factory speed, wich instruction set supported etc.
//If so, than u can use this code.
//2002 by -=LTi=-
//Free for use, just drop me a mail 
)
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
Tfrm_main = class(TForm)
img_info: TImage;
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure info(s1, s2: string);
end;
var
frm_main: Tfrm_main;
gn_speed_y: Integer;
gn_text_y: Integer;
const
gn_speed_x: Integer = 8;
gn_text_x: Integer = 15;
gl_start: Boolean = True;
implementation
{$R *.DFM}
procedure Tfrm_main.FormShow(Sender: TObject);
var
_eax, _ebx, _ecx, _edx: Longword;
i: Integer;
b: Byte;
b1: Word;
s, s1, s2, s3, s_all: string;
begin
//Set the startup colour of the image
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.FillRect(rect(0, 0, img_info.Width, img_info.Height));
gn_text_y := 5; //position of the 1st text
asm //asm call to the CPUID inst.
mov eax,0 //sub. func call
db $0F,$A2 //db $0F,$A2 = CPUID instruction
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
for i := 0 to 3 do //extract vendor id
begin
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1:= s1 + chr(b);
b := lo(_edx);
s2:= s2 + chr(b);
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
info('CPU', '');
info(' - ' + 'Vendor ID: ', s + s2 + s1);
asm
mov eax,1
db $0F,$A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
//06B1
//|0000| |0000 0000| |0000| |00| |00| |0110| |1011| |0001|
b := lo(_eax) and 15;
info(' - ' + 'Stepping ID: ', IntToStr(b));
b := lo(_eax) shr 4;
info(' - ' + 'Model Number: ', IntToHex(b, 1));
b := hi(_eax) and 15;
info(' - ' + 'Family Code: ', IntToStr(b));
b := hi(_eax) shr 4;
info(' - ' + 'Processor Type: ', IntToStr(b));
//31. 28. 27. 24. 23. 20. 19. 16.
// 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
b := lo((_eax shr 16)) and 15;
info(' - ' + 'Extended Model: ', IntToStr(b));
b := lo((_eax shr 20));
info(' - ' + 'Extended Family: ', IntToStr(b));
b := lo(_ebx);
info(' - ' + 'Brand ID: ', IntToStr(b));
b := hi(_ebx);
info(' - ' + 'Chunks: ', IntToStr(b));
b := lo(_ebx shr 16);
info(' - ' + 'Count: ', IntToStr(b));
b := hi(_ebx shr 16);
info(' - ' + 'APIC ID: ', IntToStr(b));
//Bit 18 =? 1 //is serial number enabled?
if (_edx and $40000) = $40000 then
info(' - ' + 'Serial Number ', 'Enabled')
else
info(' - ' + 'Serial Number ', 'Disabled');
s := IntToHex(_eax, 8);
asm //determine the serial number
mov eax,3
db $0F,$A2
mov _ecx,ecx
mov _edx,edx
end;
s1 := IntToHex(_edx, 8);
s2 := IntToHex(_ecx, 8);
Insert('-', s, 5);
Insert('-', s1, 5);
Insert('-', s2, 5);
info(' - ' + 'Serial Number: ', s + '-' + s1 + '-' + s2);
asm
mov eax,1
db $0F,$A2
mov _edx,edx
end;
info('', '');
//Bit 23 =? 1
if (_edx and $800000) = $800000 then
info('MMX ', 'Supported')
else
info('MMX ', 'Not Supported');
//Bit 24 =? 1
if (_edx and $01000000) = $01000000 then
info('FXSAVE & FXRSTOR Instructions ', 'Supported')
else
info('FXSAVE & FXRSTOR Instructions Not ', 'Supported');
//Bit 25 =? 1
if (_edx and $02000000) = $02000000 then
info('SSE ', 'Supported')
else
info('SSE ', 'Not Supported');
//Bit 26 =? 1
if (_edx and $04000000) = $04000000 then
info('SSE2 ', 'Supported')
else
info('SSE2 ', 'Not Supported');
info('', '');
asm //execute the extended CPUID inst.
mov eax,$80000000 //sub. func call
db $0F,$A2
mov _eax,eax
end;
if _eax > $80000000 then //any other sub. funct avail. ?
begin
info('Extended CPUID: ', 'Supported');
info(' - Largest Function Supported: ', IntToStr(_eax - $80000000));
asm //get brand ID
mov eax,$80000002
db $0F
db $A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := lo(_eax);
s3:= s3 + chr(b);
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1 := s1 + chr(b);
b := lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
s_all := s3 + s + s1 + s2;
asm
mov eax,$80000003
db $0F
db $A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := lo(_eax);
s3 := s3 + chr(b);
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1 := s1 + chr(b);
b := lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
s_all := s_all + s3 + s + s1 + s2;
asm
mov eax,$80000004
db $0F
db $A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := lo(_eax);
s3 := s3 + chr(b);
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1 := s1 + chr(b);
b := lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
info('Brand String: ', '');
if s2[Length(s2)] = #0 then setlength(s2, Length(s2) - 1);
info('', ' - ' + s_all + s3 + s + s1 + s2);
end
else
info(' - Extended CPUID ', 'Not Supported.');
end;
procedure Tfrm_main.info(s1, s2: string);
begin
if s1 <> '' then
begin
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.Font.Color := clyellow;
img_info.Canvas.TextOut(gn_text_x, gn_text_y, s1);
end;
if s2 <> '' then
begin
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.Font.Color := clWhite;
img_info.Canvas.TextOut(gn_text_x + img_info.Canvas.TextWidth(s1), gn_text_y, s2);
end;
Inc(gn_text_y, 13);
end;
end.
Delphi - .....................................
Cpu hakkında ayrıntılı bilgi
Question/Problem/Abstract:
Sometime u need to know some information about the CPU
like: brand id, factory speed, wich instruction set supported etc.
If so, than u can use this code.
2002 by -=LTi=-
Answer:
//Sometime u need to know some information about the CPU
//like: brand id, factory speed, wich instruction set supported etc.
//If so, than u can use this code.
//2002 by -=LTi=-
//Free for use, just drop me a mail )
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
Tfrm_main = class(TForm)
img_info: TImage;
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure info(s1, s2: string);
end;
var
frm_main: Tfrm_main;
gn_speed_y: Integer;
gn_text_y: Integer;
const
gn_speed_x: Integer = 8;
gn_text_x: Integer = 15;
gl_start: Boolean = True;
implementation
{$R *.DFM}
procedure Tfrm_main.FormShow(Sender: TObject);
var
_eax, _ebx, _ecx, _edx: Longword;
i: Integer;
b: Byte;
b1: Word;
s, s1, s2, s3, s_all: string;
begin
//Set the startup colour of the image
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.FillRect(rect(0, 0, img_info.Width, img_info.Height));
gn_text_y := 5; //position of the 1st text
asm //asm call to the CPUID inst.
mov eax,0 //sub. func call
db $0F,$A2 //db $0F,$A2 = CPUID instruction
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
for i := 0 to 3 do //extract vendor id
begin
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1:= s1 + chr(b);
b := lo(_edx);
s2:= s2 + chr(b);
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
info('CPU', '');
info(' - ' + 'Vendor ID: ', s + s2 + s1);
asm
mov eax,1
db $0F,$A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
//06B1
//|0000| |0000 0000| |0000| |00| |00| |0110| |1011| |0001|
b := lo(_eax) and 15;
info(' - ' + 'Stepping ID: ', IntToStr(b));
b := lo(_eax) shr 4;
info(' - ' + 'Model Number: ', IntToHex(b, 1));
b := hi(_eax) and 15;
info(' - ' + 'Family Code: ', IntToStr(b));
b := hi(_eax) shr 4;
info(' - ' + 'Processor Type: ', IntToStr(b));
//31. 28. 27. 24. 23. 20. 19. 16.
// 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
b := lo((_eax shr 16)) and 15;
info(' - ' + 'Extended Model: ', IntToStr(b));
b := lo((_eax shr 20));
info(' - ' + 'Extended Family: ', IntToStr(b));
b := lo(_ebx);
info(' - ' + 'Brand ID: ', IntToStr(b));
b := hi(_ebx);
info(' - ' + 'Chunks: ', IntToStr(b));
b := lo(_ebx shr 16);
info(' - ' + 'Count: ', IntToStr(b));
b := hi(_ebx shr 16);
info(' - ' + 'APIC ID: ', IntToStr(b));
//Bit 18 =? 1 //is serial number enabled?
if (_edx and $40000) = $40000 then
info(' - ' + 'Serial Number ', 'Enabled')
else
info(' - ' + 'Serial Number ', 'Disabled');
s := IntToHex(_eax, 8);
asm //determine the serial number
mov eax,3
db $0F,$A2
mov _ecx,ecx
mov _edx,edx
end;
s1 := IntToHex(_edx, 8);
s2 := IntToHex(_ecx, 8);
Insert('-', s, 5);
Insert('-', s1, 5);
Insert('-', s2, 5);
info(' - ' + 'Serial Number: ', s + '-' + s1 + '-' + s2);
asm
mov eax,1
db $0F,$A2
mov _edx,edx
end;
info('', '');
//Bit 23 =? 1
if (_edx and $800000) = $800000 then
info('MMX ', 'Supported')
else
info('MMX ', 'Not Supported');
//Bit 24 =? 1
if (_edx and $01000000) = $01000000 then
info('FXSAVE & FXRSTOR Instructions ', 'Supported')
else
info('FXSAVE & FXRSTOR Instructions Not ', 'Supported');
//Bit 25 =? 1
if (_edx and $02000000) = $02000000 then
info('SSE ', 'Supported')
else
info('SSE ', 'Not Supported');
//Bit 26 =? 1
if (_edx and $04000000) = $04000000 then
info('SSE2 ', 'Supported')
else
info('SSE2 ', 'Not Supported');
info('', '');
asm //execute the extended CPUID inst.
mov eax,$80000000 //sub. func call
db $0F,$A2
mov _eax,eax
end;
if _eax > $80000000 then //any other sub. funct avail. ?
begin
info('Extended CPUID: ', 'Supported');
info(' - Largest Function Supported: ', IntToStr(_eax - $80000000));
asm //get brand ID
mov eax,$80000002
db $0F
db $A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := lo(_eax);
s3:= s3 + chr(b);
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1 := s1 + chr(b);
b := lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
s_all := s3 + s + s1 + s2;
asm
mov eax,$80000003
db $0F
db $A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := lo(_eax);
s3 := s3 + chr(b);
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1 := s1 + chr(b);
b := lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
s_all := s_all + s3 + s + s1 + s2;
asm
mov eax,$80000004
db $0F
db $A2
mov _eax,eax
mov _ebx,ebx
mov _ecx,ecx
mov _edx,edx
end;
s := '';
s1 := '';
s2 := '';
s3 := '';
for i := 0 to 3 do
begin
b := lo(_eax);
s3 := s3 + chr(b);
b := lo(_ebx);
s := s + chr(b);
b := lo(_ecx);
s1 := s1 + chr(b);
b := lo(_edx);
s2 := s2 + chr(b);
_eax := _eax shr 8;
_ebx := _ebx shr 8;
_ecx := _ecx shr 8;
_edx := _edx shr 8;
end;
info('Brand String: ', '');
if s2[Length(s2)] = #0 then setlength(s2, Length(s2) - 1);
info('', ' - ' + s_all + s3 + s + s1 + s2);
end
else
info(' - Extended CPUID ', 'Not Supported.');
end;
procedure Tfrm_main.info(s1, s2: string);
begin
if s1 <> '' then
begin
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.Font.Color := clyellow;
img_info.Canvas.TextOut(gn_text_x, gn_text_y, s1);
end;
if s2 <> '' then
begin
img_info.Canvas.Brush.Color := clblue;
img_info.Canvas.Font.Color := clWhite;
img_info.Canvas.TextOut(gn_text_x + img_info.Canvas.TextWidth(s1), gn_text_y, s2);
end;
Inc(gn_text_y, 13);
end;
end.
Delphi - .....................................
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 - .....................................
)