Ras'la Kendi Dial-up Applicationı oluşturma
unit RasAppf ;
interface
uses
Windows , Messages , SysUtils , Classes ,
Graphics, Controls , Forms , Dialogs ,
ExtCtrls, StdCtrls , ComCtrls , Ras ;
type
TForm1 = class ( TForm )
Label2 : TLabel ;
Label3 : TLabel ;
Label4 : TLabel ;
Label5 : TLabel ;
Label1 : TLabel ;
btnNew : TButton ;
btnEdit : TButton ;
btnRename : TButton ;
btnDelete : TButton ;
btnHangUp : TButton ;
btnDial : TButton ;
ListBox1 : TListBox ;
StatusBar1 : TStatusBar ;
eUserName : TEdit ;
ePassWord : TEdit ;
ePhone : TEdit ;
eIPAddress : TEdit ;
Panel1 : TPanel ;
procedure FormCreate ( Sender : TObject );
procedure FormCloseQuery
( Sender : TObject ; var CanClose : Boolean );
procedure ListBox1Click ( Sender : TObject );
procedure btnDialClick ( Sender : TObject );
procedure btnHangUpClick ( Sender : TObject );
procedure btnNewClick ( Sender : TObject );
procedure btnRenameClick ( Sender : TObject );
procedure btnEditClick ( Sender : TObject );
procedure btnDeleteClick ( Sender : TObject );
private
{ Private declarations }
procedure RasGetPhoneBookEntries ;
function GetParams : boolean ;
public
{ Public declarations }
end ;
var
Form1 : TForm1 ;
// Pointer to variable to receive connection handle
RasConn : THRasConn ;
// Pointer to calling parameters
RasDialParams : TRasDialParams ;
implementation
{$R *.DFM}
procedure RasCallBack ( msg : Integer ; state : TRasConnState ;
dwError : Longint ); stdcall ;
var
S : string ;
cTxt : Array [ 0 .. 255 ] of Char ;
begin
with Form1 do begin
if ( dwError <> 0 ) then begin
RasGetErrorString ( dwError , cTxt , 256 );
S := cTxt ;
end
else
case state of
RASCS_OpenPort :
S := 'The comm port is about to be opened.' ;
RASCS_PortOpened :
S := 'The comm port has been opened successfully.' ;
RASCS_ConnectDevice :
S := 'A device is about to be connected.' ;
RASCS_DeviceConnected :
S := 'A device has connected successfully.' ;
RASCS_AllDevicesConnected :
S := 'All devices have successfully connected.' ;
RASCS_Authenticate :
S := 'The authentication process is starting.' ;
RASCS_AuthNotify :
S := 'An authentication event has occurred.' ;
RASCS_AuthRetry :
S := 'New validation attempt requested.' ;
RASCS_AuthCallback :
S := 'The remote server has requested a callback.' ;
RASCS_AuthChangePassword :
S := 'The client has requested a password change.' ;
RASCS_AuthProject :
S := 'The projection phase is starting.' ;
RASCS_AuthLinkSpeed :
S := 'The link-speed calculation phase is starting.' ;
RASCS_AuthAck :
S := 'An authentication request
is being acknowledged . ';
RASCS_ReAuthenticate :
S := 'Reauthentication (after callback) is starting.' ;
RASCS_Authenticated :
S := 'The client has successfully
completed authentication. ';
RASCS_PrepareForCallback :
S := 'The line will disconnect
in preparation for callback . ';
RASCS_WaitForModemReset :
S := 'Delaying; getting ready for a callback.' ;
RASCS_WaitForCallback :
S := 'Waiting for an incoming
call from the remote server. ';
RASCS_Projected :
S := 'Projection result information is available.' ;
RASCS_StartAuthentication :
S := 'Windows 95 only:
User authentication initiated. ';
RASCS_CallbackComplete :
S := 'Windows 95 only: Client has been called back.' ;
RASCS_LogonNetwork :
S := 'Windows 95 only:
Client is logging on to the network . ';
RASCS_Connected : begin
S := 'Successful connection.' ;
Panel1 . Color := clGreen ;
end ;
RASCS_Disconnected :
S := 'Disconnection or failed connection.' ;
end ;
StatusBar1 . SimpleText := S ;
end ;
end ;
procedure TForm1 . RasGetPhoneBookEntries ;
var
RasEntryName : array [ 1 .. 20 ] of TRasEntryName ;
i , x , BufSize , Entries : DWord ;
begin
ListBox1 . Clear ;
RasEntryName [ 1 ]. dwSize := SizeOf ( RasEntryName [ 1 ]);
BufSize := SizeOf ( RasEntryName );
x := RasEnumEntries ( nil , nil ,
@ RasEntryName , BufSize , Entries );
if ( x = 0 ) or ( x = ERROR_BUFFER_TOO_SMALL ) then
for i := 1 to Entries do
if ( i < 21 ) and ( RasEntryName [ i ]
. szEntryName [ 0 ] <> #0 ) then
ListBox1 . Items . Add ( StrPas
( RasEntryName [ i ]. szEntryName ));
end ;
function TForm1 . GetParams : boolean ;
var
fp : LongBool ;
ErrNo , ESize , DSize : Longint ;
Entry : TRasEntry ;
S : string ;
cTxt : Array [ 0 .. 255 ] of Char ;
begin
Result := false ;
if ( ListBox1 . ItemIndex < 0 ) then begin
ShowMessage ( 'Select a phonebook entry first!' );
Exit ;
end ;
with RasDialParams do begin
dwSize := Sizeof ( TRasDialParams );
StrLCopy ( szEntryName , PChar ( ListBox1 . Items
[ ListBox1 . ItemIndex ]), Ras_MaxEntryName );
end ;
ErrNo := RasGetEntryDialParams ( nil , RasDialParams , fp );
if ( ErrNo = 0 ) then
with RasDialParams do begin
eUserName . Text := szUserName ;
if fp then
ePassword . Text := szPassword ;
end
else begin
RasGetErrorString ( ErrNo , cTxt , 256 );
ShowMessage ( 'RasGetEntryDialParams failed: ' + cTxt );
Exit ;
end ;
ESize := 0 ;
DSize := 0 ;
// Try to create the TRasEntry dynamically:
Entry . dwSize := SizeOf ( TRasEntry );
RasGetEntryProperties ( nil , PChar ( ListBox1 . Items
[ ListBox1 . ItemIndex ]), nil ,
ESize , nil , DSize );
ErrNo := RasGetEntryProperties ( nil , PChar ( ListBox1 . Items
[ ListBox1 . ItemIndex ]),
@Entry , ESize , nil , DSize );
if ( ErrNo = 0 ) then with Entry do begin
if ( dwCountryCode <> null ) and ( szAreaCode <> '' ) then
ePhone . Text := IntToStr ( dwCountryCode ) + '
( ' + szAreaCode +
') ' + szLocalPhoneNumber
else if ( szAreaCode <> '' ) then
ePhone . Text := '(' + szAreaCode + ') '
+ szLocalPhoneNumber
else
ePhone . Text := szLocalPhoneNumber ;
with IPAddr do
eIPAddress . Text := IntToStr ( a ) + '.'
+ IntToStr ( b ) + '.' +
IntToStr ( c ) + '.' + IntToStr ( d );
Result := true ;
btnDial . Enabled := true ;
end
else begin
case RasGetErrorString ( ErrNo , cTxt , 256 ) of
0 : S := cTxt ;
ERROR_INSUFFICIENT_BUFFER :
S := 'ERROR_INSUFFICIENT_BUFFER' ;
ERROR_INVALID_PARAMETER :
S := 'ERROR_INVALID_PARAMETER' ;
// Error codes not defined in RasError.h
else
case ErrNo of
ERROR_INVALID_USER_BUFFER :
S := 'ERROR_INVALID_USER_BUFFER' ;
ERROR_INVALID_PARAMETER :
S := 'ERROR_INVALID_PARAMETER' ;
ERROR_BUFFER_INVALID :
S := 'ERROR_BUFFER_INVALID' ;
ERROR_BUFFER_TOO_SMALL :
S := 'ERROR_BUFFER_TOO_SMALL' ;
ERROR_CANNOT_OPEN_PHONEBOOK :
S := 'ERROR_CANNOT_OPEN_PHONEBOOK' ;
ERROR_CANNOT_FIND_PHONEBOOK_ENTRY :
S := 'ERROR_CANNOT_FIND_PHONEBOOK_ENTRY' ;
else
S := 'Unknown => ' + IntToStr ( ErrNo );
end ;
end ;
ShowMessage ( 'RasGetEntryProperties failed with: ' + S );
end ;
end ;
procedure TForm1 . FormCreate ( Sender : TObject );
begin
RasConn := 0 ;
btnHangUp . Enabled := false ;
RasGetPhoneBookEntries ;
end ;
procedure TForm1 . FormCloseQuery
( Sender : TObject ; var CanClose : Boolean );
begin
if ( RasConn <> 0 ) then
btnHangup . Click ;
end ;
procedure TForm1 . btnDialClick ( Sender : TObject );
var
ErrNo : longint ;
S : string ;
begin
btnDial . Enabled := false ;
btnHangUp . Enabled := true ;
ErrNo := RasDial ( nil , nil , RasDialParams , 0 ,
@ RasCallBack , RasConn );
if ( ErrNo <> 0 ) then begin
case ErrNo of
ERROR_BUFFER_TOO_SMALL : S := 'ERROR_BUFFER_TOO_SMALL' ;
ERROR_NOT_ENOUGH_MEMORY : S := 'ERROR_NOT_ENOUGH_MEMORY' ;
ERROR_BUFFER_INVALID : S := 'ERROR_BUFFER_INVALID' ;
else
S := 'Unknown error (' + IntToStr ( ErrNo ) + ')' ;
end ;
ShowMessage ( 'RasDial Failed with ' + S );
btnHangUp . Click ;
end ;
end ;
procedure TForm1 . btnHangUpClick ( Sender : TObject );
begin
if ( RasConn <> 0 ) then
RasHangUp ( RasConn );
RasConn := 0 ;
StatusBar1 . SimpleText := 'Call Terminated' ;
Panel1 . Color := clRed ;
btnDial . Enabled := true ;
btnHangUp . Enabled := false ;
end ;
procedure TForm1 . btnNewClick ( Sender : TObject );
begin
if ( RasCreatePhonebookEntry ( Handle , nil ) <> 0 ) then
ShowMessage ( 'Failed to create a new Phonebook Entry!' );
// Refresh the list box
RasGetPhoneBookEntries ;
end ;
procedure TForm1 . btnRenameClick ( Sender : TObject );
var
New , Old : String ;
begin
// Test for a selected entry
if ( ListBox1 . ItemIndex >= 0 ) then begin
Old := ListBox1 . Items [ ListBox1 . ItemIndex ];
New := InputBox ( 'Rename Phonebook Entry' , 'Enter new name' ,
ListBox1 . Items [ ListBox1 . ItemIndex ]);
if ( New <> '' ) then
if ( RasRenameEntry ( nil , PChar ( Old ), PChar ( New )) <> 0 )
then
ShowMessage ( 'RasRenameEntry failed.' )
else
RasGetPhoneBookEntries ;
end
else
ShowMessage ( 'Select a phonebook entry first!' );
end ;
procedure TForm1 . btnEditClick ( Sender : TObject );
begin
if ( ListBox1 . ItemIndex >= 0 ) then begin
if ( RasEditPhonebookEntry ( Handle , nil ,
PChar ( ListBox1 . Items [ ListBox1 . ItemIndex ])) <> 0 ) then
ShowMessage ( 'Edit Phonebook Entry Failed.' )
else
RasGetPhoneBookEntries ;
end
else
ShowMessage ( 'Select a phonebook entry first!' );
end ;
procedure TForm1 . btnDeleteClick ( Sender : TObject );
begin
if ( ListBox1 . ItemIndex >= 0 ) then begin
if ( Application . MessageBox ( PChar ( ListBox1 . Items
[ ListBox1 . ItemIndex ] +
' connection will be removed.' + #13#10
+ 'Are you sure?' ),
PChar ( Application . Title ), MB_YESNO or
MB_APPLMODAL or MB_ICONWARNING )
= mrYes ) then
if ( RasDeleteEntry ( nil , PChar ( ListBox1 . Items
[ ListBox1 . ItemIndex ])) <> 0 ) then
ShowMessage ( 'RasDeleteEntry failed.' )
else
RasGetPhoneBookEntries ;
end
else
ShowMessage ( 'Select a phonebook entry first!' );
end ;
procedure TForm1 . ListBox1Click ( Sender : TObject );
begin
if not GetParams then
btnDial . Enabled := false ;
end ;
end .
Delphi - .....................................
DevX - Ras'la Kendi Dial-up Applicationı oluşturma
********************************************************
********************************************************
*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***
************* 'FORUMLARDAN YARDIM İSTEYİN' *************
********************************************************
********************************************************
unit RasAppf ;
interface
uses
Windows , Messages , SysUtils , Classes ,
Graphics, Controls , Forms , Dialogs ,
ExtCtrls, StdCtrls , ComCtrls , Ras ;
type
TForm1 = class ( TForm )
Label2 : TLabel ;
Label3 : TLabel ;
Label4 : TLabel ;
Label5 : TLabel ;
Label1 : TLabel ;
btnNew : TButton ;
btnEdit : TButton ;
btnRename : TButton ;
btnDelete : TButton ;
btnHangUp : TButton ;
btnDial : TButton ;
ListBox1 : TListBox ;
StatusBar1 : TStatusBar ;
eUserName : TEdit ;
ePassWord : TEdit ;
ePhone : TEdit ;
eIPAddress : TEdit ;
Panel1 : TPanel ;
procedure FormCreate ( Sender : TObject );
procedure FormCloseQuery
( Sender : TObject ; var CanClose : Boolean );
procedure ListBox1Click ( Sender : TObject );
procedure btnDialClick ( Sender : TObject );
procedure btnHangUpClick ( Sender : TObject );
procedure btnNewClick ( Sender : TObject );
procedure btnRenameClick ( Sender : TObject );
procedure btnEditClick ( Sender : TObject );
procedure btnDeleteClick ( Sender : TObject );
private
{ Private declarations }
procedure RasGetPhoneBookEntries ;
function GetParams : boolean ;
public
{ Public declarations }
end ;
var
Form1 : TForm1 ;
// Pointer to variable to receive connection handle
RasConn : THRasConn ;
// Pointer to calling parameters
RasDialParams : TRasDialParams ;
implementation
{$R *.DFM}
procedure RasCallBack ( msg : Integer ; state : TRasConnState ;
dwError : Longint ); stdcall ;
var
S : string ;
cTxt : Array [ 0 .. 255 ] of Char ;
begin
with Form1 do begin
if ( dwError <> 0 ) then begin
RasGetErrorString ( dwError , cTxt , 256 );
S := cTxt ;
end
else
case state of
RASCS_OpenPort :
S := 'The comm port is about to be opened.' ;
RASCS_PortOpened :
S := 'The comm port has been opened successfully.' ;
RASCS_ConnectDevice :
S := 'A device is about to be connected.' ;
RASCS_DeviceConnected :
S := 'A device has connected successfully.' ;
RASCS_AllDevicesConnected :
S := 'All devices have successfully connected.' ;
RASCS_Authenticate :
S := 'The authentication process is starting.' ;
RASCS_AuthNotify :
S := 'An authentication event has occurred.' ;
RASCS_AuthRetry :
S := 'New validation attempt requested.' ;
RASCS_AuthCallback :
S := 'The remote server has requested a callback.' ;
RASCS_AuthChangePassword :
S := 'The client has requested a password change.' ;
RASCS_AuthProject :
S := 'The projection phase is starting.' ;
RASCS_AuthLinkSpeed :
S := 'The link-speed calculation phase is starting.' ;
RASCS_AuthAck :
S := 'An authentication request
is being acknowledged . ';
RASCS_ReAuthenticate :
S := 'Reauthentication (after callback) is starting.' ;
RASCS_Authenticated :
S := 'The client has successfully
completed authentication. ';
RASCS_PrepareForCallback :
S := 'The line will disconnect
in preparation for callback . ';
RASCS_WaitForModemReset :
S := 'Delaying; getting ready for a callback.' ;
RASCS_WaitForCallback :
S := 'Waiting for an incoming
call from the remote server. ';
RASCS_Projected :
S := 'Projection result information is available.' ;
RASCS_StartAuthentication :
S := 'Windows 95 only:
User authentication initiated. ';
RASCS_CallbackComplete :
S := 'Windows 95 only: Client has been called back.' ;
RASCS_LogonNetwork :
S := 'Windows 95 only:
Client is logging on to the network . ';
RASCS_Connected : begin
S := 'Successful connection.' ;
Panel1 . Color := clGreen ;
end ;
RASCS_Disconnected :
S := 'Disconnection or failed connection.' ;
end ;
StatusBar1 . SimpleText := S ;
end ;
end ;
procedure TForm1 . RasGetPhoneBookEntries ;
var
RasEntryName : array [ 1 .. 20 ] of TRasEntryName ;
i , x , BufSize , Entries : DWord ;
begin
ListBox1 . Clear ;
RasEntryName [ 1 ]. dwSize := SizeOf ( RasEntryName [ 1 ]);
BufSize := SizeOf ( RasEntryName );
x := RasEnumEntries ( nil , nil ,
@ RasEntryName , BufSize , Entries );
if ( x = 0 ) or ( x = ERROR_BUFFER_TOO_SMALL ) then
for i := 1 to Entries do
if ( i < 21 ) and ( RasEntryName [ i ]
. szEntryName [ 0 ] <> #0 ) then
ListBox1 . Items . Add ( StrPas
( RasEntryName [ i ]. szEntryName ));
end ;
function TForm1 . GetParams : boolean ;
var
fp : LongBool ;
ErrNo , ESize , DSize : Longint ;
Entry : TRasEntry ;
S : string ;
cTxt : Array [ 0 .. 255 ] of Char ;
begin
Result := false ;
if ( ListBox1 . ItemIndex < 0 ) then begin
ShowMessage ( 'Select a phonebook entry first!' );
Exit ;
end ;
with RasDialParams do begin
dwSize := Sizeof ( TRasDialParams );
StrLCopy ( szEntryName , PChar ( ListBox1 . Items
[ ListBox1 . ItemIndex ]), Ras_MaxEntryName );
end ;
ErrNo := RasGetEntryDialParams ( nil , RasDialParams , fp );
if ( ErrNo = 0 ) then
with RasDialParams do begin
eUserName . Text := szUserName ;
if fp then
ePassword . Text := szPassword ;
end
else begin
RasGetErrorString ( ErrNo , cTxt , 256 );
ShowMessage ( 'RasGetEntryDialParams failed: ' + cTxt );
Exit ;
end ;
ESize := 0 ;
DSize := 0 ;
// Try to create the TRasEntry dynamically:
Entry . dwSize := SizeOf ( TRasEntry );
RasGetEntryProperties ( nil , PChar ( ListBox1 . Items
[ ListBox1 . ItemIndex ]), nil ,
ESize , nil , DSize );
ErrNo := RasGetEntryProperties ( nil , PChar ( ListBox1 . Items
[ ListBox1 . ItemIndex ]),
@Entry , ESize , nil , DSize );
if ( ErrNo = 0 ) then with Entry do begin
if ( dwCountryCode <> null ) and ( szAreaCode <> '' ) then
ePhone . Text := IntToStr ( dwCountryCode ) + '
( ' + szAreaCode +
') ' + szLocalPhoneNumber
else if ( szAreaCode <> '' ) then
ePhone . Text := '(' + szAreaCode + ') '
+ szLocalPhoneNumber
else
ePhone . Text := szLocalPhoneNumber ;
with IPAddr do
eIPAddress . Text := IntToStr ( a ) + '.'
+ IntToStr ( b ) + '.' +
IntToStr ( c ) + '.' + IntToStr ( d );
Result := true ;
btnDial . Enabled := true ;
end
else begin
case RasGetErrorString ( ErrNo , cTxt , 256 ) of
0 : S := cTxt ;
ERROR_INSUFFICIENT_BUFFER :
S := 'ERROR_INSUFFICIENT_BUFFER' ;
ERROR_INVALID_PARAMETER :
S := 'ERROR_INVALID_PARAMETER' ;
// Error codes not defined in RasError.h
else
case ErrNo of
ERROR_INVALID_USER_BUFFER :
S := 'ERROR_INVALID_USER_BUFFER' ;
ERROR_INVALID_PARAMETER :
S := 'ERROR_INVALID_PARAMETER' ;
ERROR_BUFFER_INVALID :
S := 'ERROR_BUFFER_INVALID' ;
ERROR_BUFFER_TOO_SMALL :
S := 'ERROR_BUFFER_TOO_SMALL' ;
ERROR_CANNOT_OPEN_PHONEBOOK :
S := 'ERROR_CANNOT_OPEN_PHONEBOOK' ;
ERROR_CANNOT_FIND_PHONEBOOK_ENTRY :
S := 'ERROR_CANNOT_FIND_PHONEBOOK_ENTRY' ;
else
S := 'Unknown => ' + IntToStr ( ErrNo );
end ;
end ;
ShowMessage ( 'RasGetEntryProperties failed with: ' + S );
end ;
end ;
procedure TForm1 . FormCreate ( Sender : TObject );
begin
RasConn := 0 ;
btnHangUp . Enabled := false ;
RasGetPhoneBookEntries ;
end ;
procedure TForm1 . FormCloseQuery
( Sender : TObject ; var CanClose : Boolean );
begin
if ( RasConn <> 0 ) then
btnHangup . Click ;
end ;
procedure TForm1 . btnDialClick ( Sender : TObject );
var
ErrNo : longint ;
S : string ;
begin
btnDial . Enabled := false ;
btnHangUp . Enabled := true ;
ErrNo := RasDial ( nil , nil , RasDialParams , 0 ,
@ RasCallBack , RasConn );
if ( ErrNo <> 0 ) then begin
case ErrNo of
ERROR_BUFFER_TOO_SMALL : S := 'ERROR_BUFFER_TOO_SMALL' ;
ERROR_NOT_ENOUGH_MEMORY : S := 'ERROR_NOT_ENOUGH_MEMORY' ;
ERROR_BUFFER_INVALID : S := 'ERROR_BUFFER_INVALID' ;
else
S := 'Unknown error (' + IntToStr ( ErrNo ) + ')' ;
end ;
ShowMessage ( 'RasDial Failed with ' + S );
btnHangUp . Click ;
end ;
end ;
procedure TForm1 . btnHangUpClick ( Sender : TObject );
begin
if ( RasConn <> 0 ) then
RasHangUp ( RasConn );
RasConn := 0 ;
StatusBar1 . SimpleText := 'Call Terminated' ;
Panel1 . Color := clRed ;
btnDial . Enabled := true ;
btnHangUp . Enabled := false ;
end ;
procedure TForm1 . btnNewClick ( Sender : TObject );
begin
if ( RasCreatePhonebookEntry ( Handle , nil ) <> 0 ) then
ShowMessage ( 'Failed to create a new Phonebook Entry!' );
// Refresh the list box
RasGetPhoneBookEntries ;
end ;
procedure TForm1 . btnRenameClick ( Sender : TObject );
var
New , Old : String ;
begin
// Test for a selected entry
if ( ListBox1 . ItemIndex >= 0 ) then begin
Old := ListBox1 . Items [ ListBox1 . ItemIndex ];
New := InputBox ( 'Rename Phonebook Entry' , 'Enter new name' ,
ListBox1 . Items [ ListBox1 . ItemIndex ]);
if ( New <> '' ) then
if ( RasRenameEntry ( nil , PChar ( Old ), PChar ( New )) <> 0 )
then
ShowMessage ( 'RasRenameEntry failed.' )
else
RasGetPhoneBookEntries ;
end
else
ShowMessage ( 'Select a phonebook entry first!' );
end ;
procedure TForm1 . btnEditClick ( Sender : TObject );
begin
if ( ListBox1 . ItemIndex >= 0 ) then begin
if ( RasEditPhonebookEntry ( Handle , nil ,
PChar ( ListBox1 . Items [ ListBox1 . ItemIndex ])) <> 0 ) then
ShowMessage ( 'Edit Phonebook Entry Failed.' )
else
RasGetPhoneBookEntries ;
end
else
ShowMessage ( 'Select a phonebook entry first!' );
end ;
procedure TForm1 . btnDeleteClick ( Sender : TObject );
begin
if ( ListBox1 . ItemIndex >= 0 ) then begin
if ( Application . MessageBox ( PChar ( ListBox1 . Items
[ ListBox1 . ItemIndex ] +
' connection will be removed.' + #13#10
+ 'Are you sure?' ),
PChar ( Application . Title ), MB_YESNO or
MB_APPLMODAL or MB_ICONWARNING )
= mrYes ) then
if ( RasDeleteEntry ( nil , PChar ( ListBox1 . Items
[ ListBox1 . ItemIndex ])) <> 0 ) then
ShowMessage ( 'RasDeleteEntry failed.' )
else
RasGetPhoneBookEntries ;
end
else
ShowMessage ( 'Select a phonebook entry first!' );
end ;
procedure TForm1 . ListBox1Click ( Sender : TObject );
begin
if not GetParams then
btnDial . Enabled := false ;
end ;
end .
Delphi - .....................................
DevX - Makinem Networka baglımı
********************************************************
********************************************************
*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***
************* 'FORUMLARDAN YARDIM İSTEYİN' *************
********************************************************
********************************************************
procedure TForm1 . Button1Click ( Sender : TObject );
begin
if GetSystemMetrics ( SM_NETWORK ) AND $01 = $01 then
ShowMessage ( 'Machine is attached to network' ) else
ShowMessage ( 'Machine is not attached to network' );
end ;
Delphi - .....................................
DevX - Makinem Networka baglımı
********************************************************
********************************************************
*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***
************* 'FORUMLARDAN YARDIM İSTEYİN' *************
********************************************************
********************************************************
procedure TForm1 . Button1Click ( Sender : TObject );
begin
if GetSystemMetrics ( SM_NETWORK ) AND $01 = $01 then
ShowMessage ( 'Machine is attached to network' ) else
ShowMessage ( 'Machine is not attached to network' );
end ;
Delphi - .....................................
DevX - İnternetten Dosya Yükleme
********************************************************
********************************************************
*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***
************* 'FORUMLARDAN YARDIM İSTEYİN' *************
********************************************************
********************************************************
uses Wininet ;
function GetInetFile
( const fileURL , FileName : String ): boolean ;
const BufferSize = 1024 ;
var
hSession , hURL : HInternet ;
Buffer : array [ 1 .. BufferSize ] of Byte ;
BufferLen : DWORD ;
f : File ;
sAppName : string ;
begin
Result := False ;
sAppName := ExtractFileName ( Application . ExeName );
hSession := InternetOpen ( PChar ( sAppName ),
INTERNET_OPEN_TYPE_PRECONFIG ,
nil , nil , 0 );
try
hURL := InternetOpenURL ( hSession ,
PChar ( fileURL ),
nil , 0 , 0 , 0 );
try
AssignFile ( f , FileName );
Rewrite ( f , 1 );
repeat
InternetReadFile ( hURL , @ Buffer ,
SizeOf ( Buffer ), BufferLen );
BlockWrite ( f , Buffer , BufferLen )
until BufferLen = 0 ;
CloseFile ( f );
Result := True ;
finally
InternetCloseHandle ( hURL )
end
finally
InternetCloseHandle ( hSession )
end
end ;
var FileOnNet , LocalFileName : string
begin
FileOnNet :=
'http://delphi.about.com/library/forminbpl.zip' ;
LocalFileName := 'File Downloaded From the Net.zip'
if GetInetFile ( FileOnNet , LocalFileName )= True then
ShowMessage ( 'Download successful' )
else
ShowMessage ( 'Error in file download' )
end ;
Delphi - .....................................
DevX - İnternetten Dosya Yükleme
********************************************************
********************************************************
*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***
************* 'FORUMLARDAN YARDIM İSTEYİN' *************
********************************************************
********************************************************
uses Wininet ;
function GetInetFile
( const fileURL , FileName : String ): boolean ;
const BufferSize = 1024 ;
var
hSession , hURL : HInternet ;
Buffer : array [ 1 .. BufferSize ] of Byte ;
BufferLen : DWORD ;
f : File ;
sAppName : string ;
begin
Result := False ;
sAppName := ExtractFileName ( Application . ExeName );
hSession := InternetOpen ( PChar ( sAppName ),
INTERNET_OPEN_TYPE_PRECONFIG ,
nil , nil , 0 );
try
hURL := InternetOpenURL ( hSession ,
PChar ( fileURL ),
nil , 0 , 0 , 0 );
try
AssignFile ( f , FileName );
Rewrite ( f , 1 );
repeat
InternetReadFile ( hURL , @ Buffer ,
SizeOf ( Buffer ), BufferLen );
BlockWrite ( f , Buffer , BufferLen )
until BufferLen = 0 ;
CloseFile ( f );
Result := True ;
finally
InternetCloseHandle ( hURL )
end
finally
InternetCloseHandle ( hSession )
end
end ;
var FileOnNet , LocalFileName : string
begin
FileOnNet :=
'http://delphi.about.com/library/forminbpl.zip' ;
LocalFileName := 'File Downloaded From the Net.zip'
if GetInetFile ( FileOnNet , LocalFileName )= True then
ShowMessage ( 'Download successful' )
else
ShowMessage ( 'Error in file download' )
end ;
Delphi - .....................................
DevX - Ağdaki Başka Bilgisayara Bağlanmak
********************************************************
********************************************************
*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***
************* 'FORUMLARDAN YARDIM İSTEYİN' *************
********************************************************
********************************************************
//NetDrive.Connect(<network path>,<user name>,<password>);
unit NetDrive ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs ;
type
TNetDrive = class ( TComponent )
constructor Create ( AOwner : TComponent ); override ;
destructor Destroy ; override ;
private
FErrorString : string ;
FDrive : string ;
FOnDisconnect : TNotifyEvent ;
FOnConnect : TNotifyEvent ;
procedure SetOnConnect ( const Value : TNotifyEvent );
procedure SetOnDisconnect ( const Value : TNotifyEvent );
function FreeDriveName : string ;
function DriveExists ( ADrive : string ): boolean ;
procedure Delay ( Ams : integer );
protected
public
function Connect ( AResource , AUser , APassword : string ): string ;
function Disconnect : boolean ;
property Drive : string read FDrive ;
property ErrorString : string read FErrorString ;
published
property OnConnect : TNotifyEvent read FOnConnect write SetOnConnect ;
property OnDisconnect : TNotifyEvent read FOnDisconnect write SetOnDisconnect ;
end ;
procedure Register ;
implementation
uses
FileCtrl ;
procedure Register ;
begin
RegisterComponents ( 'MyOwn' , [ TNetDrive ]);
end ;
{ TNetDrive }
function TNetDrive . Connect ( AResource , AUser , APassword : string ): string ;
var
n : NETRESOURCE ;
i : integer ;
begin
FDrive := '' ;
n . dwScope := RESOURCE_GLOBALNET ;
n . dwType := RESOURCETYPE_DISK ;
n . dwDisplayType := RESOURCEDISPLAYTYPE_GENERIC ;
n . dwUsage := RESOURCEUSAGE_CONNECTABLE ;
n . lpLocalName := PChar ( FreeDriveName );
n . lpRemoteName := PChar ( AResource );
n . lpComment := '' ;
n . lpProvider := '' ;
i := WNetAddConnection2 ( n , PChar ( APassword ), PChar ( AUser ), 0 );
case i of
NO_ERROR : begin
delay ( 500 );
FDrive := n . lpLocalName ;
repeat until DriveExists ( FDrive );
end ;
ERROR_ACCESS_DENIED : ShowMessage ( 'Access to the network resource was denied.' );
ERROR_ALREADY_ASSIGNED : ShowMessage ( 'The local device specified by lpLocalName is already connected to a network resource.' );
ERROR_BAD_DEV_TYPE : ShowMessage ( 'The type of local device and the type of network resource do not match.' );
ERROR_BAD_DEVICE : ShowMessage ( 'The value specified by lpLocalName is invalid.' );
ERROR_BAD_NET_NAME : ShowMessage ( 'The value specified by lpRemoteName is not acceptable to any network resource provider. The resource name is invalid, or the named resource cannot be located.' );
ERROR_BAD_PROFILE : ShowMessage ( 'The user profile is in an incorrect format.' );
ERROR_BAD_PROVIDER : ShowMessage ( 'The value specified by lpProvider does not match any provider.' );
ERROR_BUSY : ShowMessage ( 'The router or provider is busy, possibly initializing. The caller should retry.' );
ERROR_CANCELLED : ShowMessage ( 'The attempt to make the connection was cancelled by the user through a dialog box from one of the network resource providers, or by a called resource.' );
ERROR_CANNOT_OPEN_PROFILE : ShowMessage ( 'The system is unable to open the user profile to process persistent connections.' );
ERROR_DEVICE_ALREADY_REMEMBERED : ShowMessage ( 'An entry for the device specified in lpLocalName is already in the user profile.' );
ERROR_EXTENDED_ERROR : ShowMessage ( 'A network-specific error occured. Call the WNetGetLastError function to get a description of the error.' );
ERROR_INVALID_PASSWORD : ShowMessage ( 'The specified password is invalid.' );
ERROR_NO_NET_OR_BAD_PATH : ShowMessage ( 'A network component has not started, or the specified name could not be handled.' );
ERROR_NO_NETWORK : ShowMessage ( 'There is no network present.' );
else ShowMessage ( 'An unknown error has occured attempting to connect to ' + AResource + '.' );
end ;
if Assigned ( FOnConnect ) then
FOnConnect ( self );
Result := FDrive ;
end ;
constructor TNetDrive . Create ( AOwner : TComponent );
begin
inherited Create ( AOwner );
FErrorString := '' ;
FDrive := '' ;
FOnDisconnect := nil ;
FOnConnect := nil ;
end ;
procedure TNetDrive . Delay ( Ams : integer );
var
h , m , s , ms : word ;
dt : TDateTime ;
begin
DecodeTime ( Time , h , m , s , ms );
ms := ms + Ams ;
while ms > 999 do
begin
inc ( s , 1 );
dec ( ms , 1000 );
end ;
while s > 59 do
begin
inc ( m , 1 );
dec ( s , 60 );
end ;
while m > 59 do
begin
inc ( h , 1 );
dec ( m , 60 );
end ;
dt := EncodeTime ( h , m , s , ms );
repeat until Time > dt ;
end ;
destructor TNetDrive . Destroy ;
begin
inherited Destroy ;
end ;
function TNetDrive . Disconnect : boolean ;
begin
result := false ;
if FDrive <> '' then
begin
case WNetCancelConnection2 ( PChar ( FDrive ), 0 , true ) of
NO_ERROR : begin
FDrive := '' ;
Result := true ;
end ;
ERROR_BAD_PROFILE : ShowMessage ( 'The user profile is in an incorrect format.' );
ERROR_CANNOT_OPEN_PROFILE : ShowMessage ( 'The system is unable to open the user profile to process persistent connections.' );
ERROR_DEVICE_IN_USE : ShowMessage ( 'The device is in use by an active process and cannot be disconnected.' );
ERROR_EXTENDED_ERROR : ShowMessage ( 'A network-specific error occurred. To get a description of the error, use the WNetGetLastError function.' );
ERROR_NOT_CONNECTED : ShowMessage ( 'The name specified by the lpName parameter is not a redirected device, or the system is not currently connected to the device specified by the parameter.' );
ERROR_OPEN_FILES : ShowMessage ( 'There are open files, and the fForce parameter is FALSE.' );
end ;
if Assigned ( FOnDisconnect ) then
FOnDisconnect ( self );
end ;
end ;
function TNetDrive . DriveExists ( ADrive : string ): boolean ;
var
buf : string ;
begin
GetDir ( 0 , buf );
{$I-}
ChDir ( ADrive );
{$I+}
Result :=( IOResult = 0 );
ChDir ( buf );
end ;
function TNetDrive . FreeDriveName : string ;
var
l : TStringList ;
d : TDriveComboBox ;
t : char ;
i : integer ;
begin
l := TStringList . Create ;
d := TDriveComboBox . Create ( self );
d . Parent := Application . MainForm ;
d . Visible := false ;
l . Assign ( d . Items );
d . Free ;
for i := 0 to l . Count - 1 do
l [ i ]:= copy ( l [ i ], 1 , 1 );
t := 'd' ;
result := '' ;
while ( t <= 'z' ) and ( result = '' ) do
if l . IndexOf ( t )=- 1
then result := t
else inc ( t );
l . Free ;
if result <> '' then
result := result + ':' ;
end ;
procedure TNetDrive . SetOnConnect ( const Value : TNotifyEvent );
begin
FOnConnect := Value ;
end ;
procedure TNetDrive . SetOnDisconnect ( const Value : TNotifyEvent );
begin
FOnDisconnect := Value ;
end ;
end .
Delphi - .....................................
DevX - Ağdaki Başka Bilgisayara Bağlanmak
********************************************************
********************************************************
*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***
************* 'FORUMLARDAN YARDIM İSTEYİN' *************
********************************************************
********************************************************
//NetDrive.Connect(<network path>,<user name>,<password>);
unit NetDrive ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs ;
type
TNetDrive = class ( TComponent )
constructor Create ( AOwner : TComponent ); override ;
destructor Destroy ; override ;
private
FErrorString : string ;
FDrive : string ;
FOnDisconnect : TNotifyEvent ;
FOnConnect : TNotifyEvent ;
procedure SetOnConnect ( const Value : TNotifyEvent );
procedure SetOnDisconnect ( const Value : TNotifyEvent );
function FreeDriveName : string ;
function DriveExists ( ADrive : string ): boolean ;
procedure Delay ( Ams : integer );
protected
public
function Connect ( AResource , AUser , APassword : string ): string ;
function Disconnect : boolean ;
property Drive : string read FDrive ;
property ErrorString : string read FErrorString ;
published
property OnConnect : TNotifyEvent read FOnConnect write SetOnConnect ;
property OnDisconnect : TNotifyEvent read FOnDisconnect write SetOnDisconnect ;
end ;
procedure Register ;
implementation
uses
FileCtrl ;
procedure Register ;
begin
RegisterComponents ( 'MyOwn' , [ TNetDrive ]);
end ;
{ TNetDrive }
function TNetDrive . Connect ( AResource , AUser , APassword : string ): string ;
var
n : NETRESOURCE ;
i : integer ;
begin
FDrive := '' ;
n . dwScope := RESOURCE_GLOBALNET ;
n . dwType := RESOURCETYPE_DISK ;
n . dwDisplayType := RESOURCEDISPLAYTYPE_GENERIC ;
n . dwUsage := RESOURCEUSAGE_CONNECTABLE ;
n . lpLocalName := PChar ( FreeDriveName );
n . lpRemoteName := PChar ( AResource );
n . lpComment := '' ;
n . lpProvider := '' ;
i := WNetAddConnection2 ( n , PChar ( APassword ), PChar ( AUser ), 0 );
case i of
NO_ERROR : begin
delay ( 500 );
FDrive := n . lpLocalName ;
repeat until DriveExists ( FDrive );
end ;
ERROR_ACCESS_DENIED : ShowMessage ( 'Access to the network resource was denied.' );
ERROR_ALREADY_ASSIGNED : ShowMessage ( 'The local device specified by lpLocalName is already connected to a network resource.' );
ERROR_BAD_DEV_TYPE : ShowMessage ( 'The type of local device and the type of network resource do not match.' );
ERROR_BAD_DEVICE : ShowMessage ( 'The value specified by lpLocalName is invalid.' );
ERROR_BAD_NET_NAME : ShowMessage ( 'The value specified by lpRemoteName is not acceptable to any network resource provider. The resource name is invalid, or the named resource cannot be located.' );
ERROR_BAD_PROFILE : ShowMessage ( 'The user profile is in an incorrect format.' );
ERROR_BAD_PROVIDER : ShowMessage ( 'The value specified by lpProvider does not match any provider.' );
ERROR_BUSY : ShowMessage ( 'The router or provider is busy, possibly initializing. The caller should retry.' );
ERROR_CANCELLED : ShowMessage ( 'The attempt to make the connection was cancelled by the user through a dialog box from one of the network resource providers, or by a called resource.' );
ERROR_CANNOT_OPEN_PROFILE : ShowMessage ( 'The system is unable to open the user profile to process persistent connections.' );
ERROR_DEVICE_ALREADY_REMEMBERED : ShowMessage ( 'An entry for the device specified in lpLocalName is already in the user profile.' );
ERROR_EXTENDED_ERROR : ShowMessage ( 'A network-specific error occured. Call the WNetGetLastError function to get a description of the error.' );
ERROR_INVALID_PASSWORD : ShowMessage ( 'The specified password is invalid.' );
ERROR_NO_NET_OR_BAD_PATH : ShowMessage ( 'A network component has not started, or the specified name could not be handled.' );
ERROR_NO_NETWORK : ShowMessage ( 'There is no network present.' );
else ShowMessage ( 'An unknown error has occured attempting to connect to ' + AResource + '.' );
end ;
if Assigned ( FOnConnect ) then
FOnConnect ( self );
Result := FDrive ;
end ;
constructor TNetDrive . Create ( AOwner : TComponent );
begin
inherited Create ( AOwner );
FErrorString := '' ;
FDrive := '' ;
FOnDisconnect := nil ;
FOnConnect := nil ;
end ;
procedure TNetDrive . Delay ( Ams : integer );
var
h , m , s , ms : word ;
dt : TDateTime ;
begin
DecodeTime ( Time , h , m , s , ms );
ms := ms + Ams ;
while ms > 999 do
begin
inc ( s , 1 );
dec ( ms , 1000 );
end ;
while s > 59 do
begin
inc ( m , 1 );
dec ( s , 60 );
end ;
while m > 59 do
begin
inc ( h , 1 );
dec ( m , 60 );
end ;
dt := EncodeTime ( h , m , s , ms );
repeat until Time > dt ;
end ;
destructor TNetDrive . Destroy ;
begin
inherited Destroy ;
end ;
function TNetDrive . Disconnect : boolean ;
begin
result := false ;
if FDrive <> '' then
begin
case WNetCancelConnection2 ( PChar ( FDrive ), 0 , true ) of
NO_ERROR : begin
FDrive := '' ;
Result := true ;
end ;
ERROR_BAD_PROFILE : ShowMessage ( 'The user profile is in an incorrect format.' );
ERROR_CANNOT_OPEN_PROFILE : ShowMessage ( 'The system is unable to open the user profile to process persistent connections.' );
ERROR_DEVICE_IN_USE : ShowMessage ( 'The device is in use by an active process and cannot be disconnected.' );
ERROR_EXTENDED_ERROR : ShowMessage ( 'A network-specific error occurred. To get a description of the error, use the WNetGetLastError function.' );
ERROR_NOT_CONNECTED : ShowMessage ( 'The name specified by the lpName parameter is not a redirected device, or the system is not currently connected to the device specified by the parameter.' );
ERROR_OPEN_FILES : ShowMessage ( 'There are open files, and the fForce parameter is FALSE.' );
end ;
if Assigned ( FOnDisconnect ) then
FOnDisconnect ( self );
end ;
end ;
function TNetDrive . DriveExists ( ADrive : string ): boolean ;
var
buf : string ;
begin
GetDir ( 0 , buf );
{$I-}
ChDir ( ADrive );
{$I+}
Result :=( IOResult = 0 );
ChDir ( buf );
end ;
function TNetDrive . FreeDriveName : string ;
var
l : TStringList ;
d : TDriveComboBox ;
t : char ;
i : integer ;
begin
l := TStringList . Create ;
d := TDriveComboBox . Create ( self );
d . Parent := Application . MainForm ;
d . Visible := false ;
l . Assign ( d . Items );
d . Free ;
for i := 0 to l . Count - 1 do
l [ i ]:= copy ( l [ i ], 1 , 1 );
t := 'd' ;
result := '' ;
while ( t <= 'z' ) and ( result = '' ) do
if l . IndexOf ( t )=- 1
then result := t
else inc ( t );
l . Free ;
if result <> '' then
result := result + ':' ;
end ;
procedure TNetDrive . SetOnConnect ( const Value : TNotifyEvent );
begin
FOnConnect := Value ;
end ;
procedure TNetDrive . SetOnDisconnect ( const Value : TNotifyEvent );
begin
FOnDisconnect := Value ;
end ;
end .
Delphi - .....................................
DevX - Disket Varmı?,Serial Numarası,İçerik Boyutu,Formatı
********************************************************
********************************************************
*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***
************* 'FORUMLARDAN YARDIM İSTEYİN' *************
********************************************************
********************************************************
unit floppy ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs ,
StdCtrls , ShellApi ;
type
TForm1 = class ( TForm )
Button1 : TButton ;
Button3 : TButton ;
Button2 : TButton ;
Button4 : TButton ;
procedure Button3Click ( Sender : TObject );
procedure Button1Click ( Sender : TObject );
procedure Button2Click ( Sender : TObject );
procedure Button4Click ( Sender : TObject );
private
{ Private declarations }
public
{ Public declarations }
end ;
var
Form1 : TForm1 ;
implementation
{$R *.DFM}
procedure TForm1 . Button3Click ( Sender : TObject );
var VolumeSerialNumber : DWORD ;
MaximumComponentLength : DWORD ;
FileSystemFlags : DWORD ;
SerialNumber : string ;
begin
GetVolumeInformation ( 'A:' ,
nil ,
0 ,
@VolumeSerialNumber ,
MaximumComponentLength ,
FileSystemFlags ,
nil ,
0 );
SerialNumber := IntToHex ( HiWord ( VolumeSerialNumber ), 4 )+
' - ' +
IntToHex ( LoWord ( VolumeSerialNumber ), 4 );
ShowMessage ( SerialNumber );
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
var EMode : Word ;
begin
EMode := SetErrorMode ( SEM_FAILCRITICALERRORS );
try
if DiskSize ( Ord ( 'A' )- $40 ) <> - 1 then
ShowMessage ( 'Disk in drive A: !' )
else
ShowMessage( 'No disk in drive A: !' );
finally
SetErrorMode ( EMode );
end ;
end ;
procedure TForm1 . Button2Click ( Sender : TObject );
var FreeTotal , SizeTotal : Integer ;
sFD , sSD : string ;
begin
FreeTotal := DiskFree ( 1 );
if FreeTotal <> - 1 then begin
SizeTotal := DiskSize ( 1 );
if SizeTotal <> - 1 then begin
FreeTotal := FreeTotal div 1024 ;
SizeTotal := SizeTotal div 1024 ;
sFD := 'Disk Free: ' + Format ( '%d' ,[ FreeTotal ]) + ' Kb' ;
sSD := 'Disk Size: ' + Format ( '%d' ,[ SizeTotal ]) + ' Kb' ;
ShowMessage ( sFD + #13 + sSD );
end ;
end ;
end ;
function SHFormatDrive ( hWnd : HWND ;
Drive : Word ;
fmtID : Word ;
Options : Word ) : Longint
stdcall ; external 'Shell32.dll' name 'SHFormatDrive' ;
procedure TForm1 . Button4Click ( Sender : TObject );
const
SHFMT_DRV_A = 0 ;
SHFMT_DRV_B = 1 ;
SHFMT_ID_DEFAULT = $FFFF ;
SHFMT_OPT_QUICKFORMAT = 0 ;
SHFMT_OPT_FULLFORMAT = 1 ;
SHFMT_OPT_SYSONLY = 2 ;
SHFMT_ERROR = - 1 ;
SHFMT_CANCEL = - 2 ;
SHFMT_NOFORMAT = - 3 ;
var
FmtRes : LongInt ;
begin
try
FmtRes:= ShFormatDrive ( Handle ,
SHFMT_DRV_A ,
SHFMT_ID_DEFAULT ,
SHFMT_OPT_QUICKFORMAT );
case FmtRes of
SHFMT_ERROR:
ShowMessage( 'Error formatting the drive' );
SHFMT_CANCEL :
ShowMessage( 'User canceled formatting the drive' );
SHFMT_NOFORMAT :
ShowMessage( 'Drive is not formatable' )
else
ShowMessage( 'Disk has been formatted' );
end ;
except
ShowMessage ( 'Error occurred!' )
end ;
end ;
end .
Delphi - .....................................
DevX - Disket Varmı?,Serial Numarası,İçerik Boyutu,Formatı
********************************************************
********************************************************
*** 'ARKADAŞLAR LÜTFEN KODBANK"TAN YARDIM İSTEMEYİN' ***
************* 'FORUMLARDAN YARDIM İSTEYİN' *************
********************************************************
********************************************************
unit floppy ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms , Dialogs ,
StdCtrls , ShellApi ;
type
TForm1 = class ( TForm )
Button1 : TButton ;
Button3 : TButton ;
Button2 : TButton ;
Button4 : TButton ;
procedure Button3Click ( Sender : TObject );
procedure Button1Click ( Sender : TObject );
procedure Button2Click ( Sender : TObject );
procedure Button4Click ( Sender : TObject );
private
{ Private declarations }
public
{ Public declarations }
end ;
var
Form1 : TForm1 ;
implementation
{$R *.DFM}
procedure TForm1 . Button3Click ( Sender : TObject );
var VolumeSerialNumber : DWORD ;
MaximumComponentLength : DWORD ;
FileSystemFlags : DWORD ;
SerialNumber : string ;
begin
GetVolumeInformation ( 'A:' ,
nil ,
0 ,
@VolumeSerialNumber ,
MaximumComponentLength ,
FileSystemFlags ,
nil ,
0 );
SerialNumber := IntToHex ( HiWord ( VolumeSerialNumber ), 4 )+
' - ' +
IntToHex ( LoWord ( VolumeSerialNumber ), 4 );
ShowMessage ( SerialNumber );
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
var EMode : Word ;
begin
EMode := SetErrorMode ( SEM_FAILCRITICALERRORS );
try
if DiskSize ( Ord ( 'A' )- $40 ) <> - 1 then
ShowMessage ( 'Disk in drive A: !' )
else
ShowMessage( 'No disk in drive A: !' );
finally
SetErrorMode ( EMode );
end ;
end ;
procedure TForm1 . Button2Click ( Sender : TObject );
var FreeTotal , SizeTotal : Integer ;
sFD , sSD : string ;
begin
FreeTotal := DiskFree ( 1 );
if FreeTotal <> - 1 then begin
SizeTotal := DiskSize ( 1 );
if SizeTotal <> - 1 then begin
FreeTotal := FreeTotal div 1024 ;
SizeTotal := SizeTotal div 1024 ;
sFD := 'Disk Free: ' + Format ( '%d' ,[ FreeTotal ]) + ' Kb' ;
sSD := 'Disk Size: ' + Format ( '%d' ,[ SizeTotal ]) + ' Kb' ;
ShowMessage ( sFD + #13 + sSD );
end ;
end ;
end ;
function SHFormatDrive ( hWnd : HWND ;
Drive : Word ;
fmtID : Word ;
Options : Word ) : Longint
stdcall ; external 'Shell32.dll' name 'SHFormatDrive' ;
procedure TForm1 . Button4Click ( Sender : TObject );
const
SHFMT_DRV_A = 0 ;
SHFMT_DRV_B = 1 ;
SHFMT_ID_DEFAULT = $FFFF ;
SHFMT_OPT_QUICKFORMAT = 0 ;
SHFMT_OPT_FULLFORMAT = 1 ;
SHFMT_OPT_SYSONLY = 2 ;
SHFMT_ERROR = - 1 ;
SHFMT_CANCEL = - 2 ;
SHFMT_NOFORMAT = - 3 ;
var
FmtRes : LongInt ;
begin
try
FmtRes:= ShFormatDrive ( Handle ,
SHFMT_DRV_A ,
SHFMT_ID_DEFAULT ,
SHFMT_OPT_QUICKFORMAT );
case FmtRes of
SHFMT_ERROR:
ShowMessage( 'Error formatting the drive' );
SHFMT_CANCEL :
ShowMessage( 'User canceled formatting the drive' );
SHFMT_NOFORMAT :
ShowMessage( 'Drive is not formatable' )
else
ShowMessage( 'Disk has been formatted' );
end ;
except
ShowMessage ( 'Error occurred!' )
end ;
end ;
end .
Delphi - .....................................
DBASE (MDX,NDX) ve PARADOX index oluşturma
yabancı bir siteden buldum bir ç ok ki ş inin i ş ine yaraca ğı na inann ı yorum
Example 1 : Create a maintained , case insensitive index on the first and second fields on a Paradox tables . The first field of the index is descending and the second is ascending .
This example uses the following input :
fDbiAddIndex6 ( Table1 )
Procedure fDbiAddIndex6 ( Tbl : TTable );
var
NewIndex : IDXDesc ;
begin
FillChar ( NewIndex , SizeOf ( NewIndex ), 0 );
if Tbl . Exclusive = False then
raise EDatabaseError . Create
( 'TTable.Exclusive must be set to true in order to add an index to the table' );
NewIndex . szName := 'NewIndex2' ;
NewIndex . iIndexId := 0 ;
NewIndex . bPrimary := FALSE ;
NewIndex . bUnique := FALSE ;
NewIndex . bDescending := TRUE ;
NewIndex . bMaintained := TRUE ;
NewIndex . bSubset := FALSE ;
NewIndex . bExpIdx := FALSE ;
NewIndex . iFldsInKey := 2 ;
NewIndex . aiKeyFld [ 0 ]:= 1 ;
NewIndex . aiKeyFld [ 1 ]:= 2 ;
NewIndex . abDescending [ 0 ]:= TRUE ;
NewIndex . abDescending [ 1 ]:= FALSE ;
NewIndex . bCaseInsensitive := TRUE ;
Check ( DbiAddIndex ( Tbl . dbhandle , Tbl . handle , PChar ( Tbl . TableName ),
szPARADOX , NewIndex , nil ));
end ;
Example 2 : Create a maintained , expression index with a subset filter .
This example uses the following input :
AddExpFilter ( Table1 , 'OUTRISK' , 'STR(OUTLOOK)+RISK' , 'RISK=''HIGH''' );
You can use this input with the master . dbf table in the delphi / demos / data directory .
Note : You can only use expression indexes with dBASE and FoxPro tables .
procedure AddExpFilter ( Table : TTable ; TagName , Expression , Filter : string );
var
NewIndex : IDXDesc ;
begin
if TagName = '' then
raise EDatabaseError . Create ( 'A tag name must be supplied to create an expression index' );
if Expression = '' then
raise EDatabaseError . Create ( 'A expression be supplied to create an index' );
if Table . exclusive = False then
raise EDatabaseError . Create ( 'Table: ' + Table . Tablename + ' must be opened exclusively '
+ 'to create an index' );
FillChar ( NewIndex , sizeof ( NewIndex ), 0 );
StrPCopy ( NewIndex . szTagName , TagName );
NewIndex . bPrimary := False ;
NewIndex . bUnique := False ;
NewIndex . bDescending := False ;
NewIndex . bMaintained := True ;
if Filter = '' then
NewIndex . bSubset := False
else
NewIndex . bSubset := True ;
NewIndex . bExpIdx := True ;
StrPCopy ( NewIndex . szKeyExp , Expression );
StrPCopy ( NewIndex . szKeyCond , Filter );
NewIndex . bCaseInsensitive := False ;
Check ( DbiAddIndex ( Table . dbhandle , Table . handle , PChar ( Table . TableName ),
szDBASE , NewIndex , nil ));
end ;
Example 3 : Create a multi - field secondary index on a Paradox table .
This example uses the following input :
AddMultiFieldIndex ( Table2 , 'Multi' , False , [ Table2 . Fields [ 0 ], Table2 . Fields [ 2 ], Table2 . Fields [ 1 ]]);
procedure AddMultiFieldIndex ( Table : TTable ; IndexName : string ; Unique : boolean ;
const Fields : array of TField );
var
NewIndex : IDXDesc ;
b : byte ;
Props : CURProps ;
begin
// Make sure an index name is supplied...
if IndexName = '' then
raise EDatabaseError . Create ( 'An index name must be supplied' );
// Make sure the table is opened exclusively...
if Table . exclusive = False then
raise EDatabaseError . Create ( 'Table: ' + Table . Tablename +
' must be opened exclusively to create an index' );
Check ( DbiGetCursorProps ( Table . Handle , Props ));
// Make sure the table is of type PARADOX...
if StrComp ( Props . szTableType , szPARADOX ) <> 0 then
raise EDatabaseError . Create ( 'Table must be of type PARADOX' );
FillChar ( NewIndex , sizeof ( NewIndex ), 0 );
StrPCopy ( NewIndex . szName , IndexName );
NewIndex . bUnique := Unique ;
NewIndex . bMaintained := True ;
// Set the field mappings for the multi field index...
NewIndex . iFldsInKey := sizeof ( Fields ) div sizeof ( TField );
for b := 0 to NewIndex . iFldsInkey - 1 do
NewIndex . aiKeyFld [ b ] := Fields [ b ]. Index + 1 ;
// Create the index...
Check ( DbiAddIndex ( Table . dbhandle , Table . handle , nil , nil , NewIndex , nil ));
end ;
Example 4 : Create a dBASE . NDX ( non - maintained ) index
This example uses the following input :
fDbiAddIndex7 ( Table1 , 'Last3.ndx' , 'Last_Name' );
procedure fDbiAddIndex7 ( Tbl : TTable ; indexname , fieldname : string );
var
NewIndex : IDXDesc ;
Props : CURProps ;
begin
// Make sure the table is opened exclusively...
if Tbl . exclusive = False then
raise EDatabaseError . Create ( 'Table: ' + Tbl . Tablename +
' must be opened exclusively to create an index' );
Check ( DbiGetCursorProps ( Tbl . Handle , Props ));
// Make sure the table is of type dBASE...
if StrComp ( Props . szTableType , szDBASE ) <> 0 then
raise EDatabaseError . Create ( 'Table must be of type dBASE' );
FillChar ( NewIndex , sizeof ( IDXDesc ) - 1 , 0 );
//Convert to uppercase so string compare is easy
indexname := UpperCase ( indexname );
//indexname must end in .NDX, so add it if not already there
if copy ( indexname , length ( indexname )- 3 , 4 ) <> '.NDX' then
indexname := indexname + '.NDX' ;
AnsiToNative ( Tbl . Locale , indexname , NewIndex . szname , DBIMAXTBLNAMELEN - 1 );
NewIndex . bPrimary := False ;
NewIndex . bUnique := False ;
NewIndex . bDescending := False ;
NewIndex . bMaintained := False ;
NewIndex . bExpIdx := False ;
NewIndex . iFldsInKey := 1 ;
NewIndex . aiKeyFld [ 0 ] := Tbl . FieldbyName ( fieldname ). FieldNo ;
NewIndex . bCaseInsensitive := False ;
Check ( DbiAddIndex ( Tbl . dbhandle , Tbl . handle , PChar ( Tbl . TableName ),
szDBASE , NewIndex , nil ));
end ;
Delphi - .....................................
DBASE (MDX,NDX) ve PARADOX index oluşturma
yabancı bir siteden buldum bir ç ok ki ş inin i ş ine yaraca ğı na inann ı yorum
Example 1 : Create a maintained , case insensitive index on the first and second fields on a Paradox tables . The first field of the index is descending and the second is ascending .
This example uses the following input :
fDbiAddIndex6 ( Table1 )
Procedure fDbiAddIndex6 ( Tbl : TTable );
var
NewIndex : IDXDesc ;
begin
FillChar ( NewIndex , SizeOf ( NewIndex ), 0 );
if Tbl . Exclusive = False then
raise EDatabaseError . Create
( 'TTable.Exclusive must be set to true in order to add an index to the table' );
NewIndex . szName := 'NewIndex2' ;
NewIndex . iIndexId := 0 ;
NewIndex . bPrimary := FALSE ;
NewIndex . bUnique := FALSE ;
NewIndex . bDescending := TRUE ;
NewIndex . bMaintained := TRUE ;
NewIndex . bSubset := FALSE ;
NewIndex . bExpIdx := FALSE ;
NewIndex . iFldsInKey := 2 ;
NewIndex . aiKeyFld [ 0 ]:= 1 ;
NewIndex . aiKeyFld [ 1 ]:= 2 ;
NewIndex . abDescending [ 0 ]:= TRUE ;
NewIndex . abDescending [ 1 ]:= FALSE ;
NewIndex . bCaseInsensitive := TRUE ;
Check ( DbiAddIndex ( Tbl . dbhandle , Tbl . handle , PChar ( Tbl . TableName ),
szPARADOX , NewIndex , nil ));
end ;
Example 2 : Create a maintained , expression index with a subset filter .
This example uses the following input :
AddExpFilter ( Table1 , 'OUTRISK' , 'STR(OUTLOOK)+RISK' , 'RISK=''HIGH''' );
You can use this input with the master . dbf table in the delphi / demos / data directory .
Note : You can only use expression indexes with dBASE and FoxPro tables .
procedure AddExpFilter ( Table : TTable ; TagName , Expression , Filter : string );
var
NewIndex : IDXDesc ;
begin
if TagName = '' then
raise EDatabaseError . Create ( 'A tag name must be supplied to create an expression index' );
if Expression = '' then
raise EDatabaseError . Create ( 'A expression be supplied to create an index' );
if Table . exclusive = False then
raise EDatabaseError . Create ( 'Table: ' + Table . Tablename + ' must be opened exclusively '
+ 'to create an index' );
FillChar ( NewIndex , sizeof ( NewIndex ), 0 );
StrPCopy ( NewIndex . szTagName , TagName );
NewIndex . bPrimary := False ;
NewIndex . bUnique := False ;
NewIndex . bDescending := False ;
NewIndex . bMaintained := True ;
if Filter = '' then
NewIndex . bSubset := False
else
NewIndex . bSubset := True ;
NewIndex . bExpIdx := True ;
StrPCopy ( NewIndex . szKeyExp , Expression );
StrPCopy ( NewIndex . szKeyCond , Filter );
NewIndex . bCaseInsensitive := False ;
Check ( DbiAddIndex ( Table . dbhandle , Table . handle , PChar ( Table . TableName ),
szDBASE , NewIndex , nil ));
end ;
Example 3 : Create a multi - field secondary index on a Paradox table .
This example uses the following input :
AddMultiFieldIndex ( Table2 , 'Multi' , False , [ Table2 . Fields [ 0 ], Table2 . Fields [ 2 ], Table2 . Fields [ 1 ]]);
procedure AddMultiFieldIndex ( Table : TTable ; IndexName : string ; Unique : boolean ;
const Fields : array of TField );
var
NewIndex : IDXDesc ;
b : byte ;
Props : CURProps ;
begin
// Make sure an index name is supplied...
if IndexName = '' then
raise EDatabaseError . Create ( 'An index name must be supplied' );
// Make sure the table is opened exclusively...
if Table . exclusive = False then
raise EDatabaseError . Create ( 'Table: ' + Table . Tablename +
' must be opened exclusively to create an index' );
Check ( DbiGetCursorProps ( Table . Handle , Props ));
// Make sure the table is of type PARADOX...
if StrComp ( Props . szTableType , szPARADOX ) <> 0 then
raise EDatabaseError . Create ( 'Table must be of type PARADOX' );
FillChar ( NewIndex , sizeof ( NewIndex ), 0 );
StrPCopy ( NewIndex . szName , IndexName );
NewIndex . bUnique := Unique ;
NewIndex . bMaintained := True ;
// Set the field mappings for the multi field index...
NewIndex . iFldsInKey := sizeof ( Fields ) div sizeof ( TField );
for b := 0 to NewIndex . iFldsInkey - 1 do
NewIndex . aiKeyFld [ b ] := Fields [ b ]. Index + 1 ;
// Create the index...
Check ( DbiAddIndex ( Table . dbhandle , Table . handle , nil , nil , NewIndex , nil ));
end ;
Example 4 : Create a dBASE . NDX ( non - maintained ) index
This example uses the following input :
fDbiAddIndex7 ( Table1 , 'Last3.ndx' , 'Last_Name' );
procedure fDbiAddIndex7 ( Tbl : TTable ; indexname , fieldname : string );
var
NewIndex : IDXDesc ;
Props : CURProps ;
begin
// Make sure the table is opened exclusively...
if Tbl . exclusive = False then
raise EDatabaseError . Create ( 'Table: ' + Tbl . Tablename +
' must be opened exclusively to create an index' );
Check ( DbiGetCursorProps ( Tbl . Handle , Props ));
// Make sure the table is of type dBASE...
if StrComp ( Props . szTableType , szDBASE ) <> 0 then
raise EDatabaseError . Create ( 'Table must be of type dBASE' );
FillChar ( NewIndex , sizeof ( IDXDesc ) - 1 , 0 );
//Convert to uppercase so string compare is easy
indexname := UpperCase ( indexname );
//indexname must end in .NDX, so add it if not already there
if copy ( indexname , length ( indexname )- 3 , 4 ) <> '.NDX' then
indexname := indexname + '.NDX' ;
AnsiToNative ( Tbl . Locale , indexname , NewIndex . szname , DBIMAXTBLNAMELEN - 1 );
NewIndex . bPrimary := False ;
NewIndex . bUnique := False ;
NewIndex . bDescending := False ;
NewIndex . bMaintained := False ;
NewIndex . bExpIdx := False ;
NewIndex . iFldsInKey := 1 ;
NewIndex . aiKeyFld [ 0 ] := Tbl . FieldbyName ( fieldname ). FieldNo ;
NewIndex . bCaseInsensitive := False ;
Check ( DbiAddIndex ( Tbl . dbhandle , Tbl . handle , PChar ( Tbl . TableName ),
szDBASE , NewIndex , nil ));
end ;
