Delphi -- Graphic İpuçları
Delphi -- Graphic İ pu ç lar ı
1. 3 D Yaz ı yazmak ..
procedure imgPaintCanvas ( TheCanvas : TCanvas ; TheString : String ; TheFontSize , UCorner , LCorner : Integer );
Begin
TheCanvas . Brush . Style := bsClear ;
TheCanvas . Font . Style := [ fsBold ];
TheCanvas . Font . Name := 'MS Sans Serif' ;
TheCanvas . Font . Size := TheFontSize ;
TheCanvas . Font . Color := clBlack ;
TheCanvas . TextOut ( UCorner , LCorner , TheString );
TheCanvas . Font . Color := clGray ;
TheCanvas . TextOut ( UCorner - 1 , LCorner - 1 , TheString );
TheCanvas . Font . Color := clSilver ;
TheCanvas . TextOut ( UCorner - 2 , LCorner - 2 , TheString );
TheCanvas . Font . Color := clBlack ;
TheCanvas . TextOut ( UCorner - 3 , LCorner - 3 , TheString );
End ;
//Şöyle Çalışıyor
imgPaintCanvas ( Image3 . Canvas , '0' , 10 , 6 , 4 );
2. Form da MetaFile ç izmek ...
implementation
{$R *.DFM}
type
TMetafileCanvas = class ( TCanvas )
private
FClipboardHandle : THandle ;
FMetafileHandle : HMetafile ;
FRect : TRect ;
protected
procedure CreateHandle ; override ;
function GetMetafileHandle : HMetafile ;
public
constructor Create ;
destructor Destroy ; override ;
property Rect : TRect read FRect write FRect ;
property MetafileHandle : HMetafile read GetMetafileHandle ;
end ;
constructor TMetafileCanvas . Create ;
begin
inherited Create ;
FClipboardHandle := GlobalAlloc (
GMEM_SHARE or GMEM_ZEROINIT , SizeOf ( TMetafilePict ));
end ;
destructor TMetafileCanvas . Destroy ;
begin
DeleteMetafile ( CloseMetafile ( Handle ));
if Bool ( FClipboardHandle ) then GlobalFree ( FClipboardHandle );
if Bool ( FMetafileHandle ) then DeleteMetafile ( FMetafileHandle );
inherited Destroy ;
end ;
procedure TMetafileCanvas . CreateHandle ;
var
MetafileDC : HDC ;
begin
MetafileDC := CreateMetaFile ( nil );
if Bool ( MetafileDC ) then
begin
with FRect do SetWindowOrg ( MetafileDC , Left - 10 , Top - 10 );
with FRect do SetWindowExt ( MetafileDC , Right - Left + 20 , Bottom - Top + 20 );
if Bool ( FMetafileHandle ) then
begin
PlayMetafile ( MetafileDC , FMetafileHandle );
end ;
end ;
Handle := MetafileDC ;
end ;
function TMetafileCanvas . GetMetafileHandle : HMetafile ;
var
MetafilePict : PMetafilePict ;
IC : HDC ;
ExtRect : TRect ;
begin
if Bool ( FMetafileHandle ) then DeleteMetafile ( FMetafileHandle );
FMetafileHandle := CloseMetafile ( Handle );
Handle := 0 ;
MetafilePict := GlobalLock ( FClipboardHandle );
MetafilePict ^. mm := mm_AnIsoTropic ;
IC := CreateIC ( 'DISPLAY' , nil , nil , nil );
SetMapMode ( IC , mm_HiMetric );
ExtRect := FRect ;
DPtoLP ( IC , ExtRect , 2 );
DeleteDC ( IC );
MetafilePict ^. xExt := ExtRect . Right - ExtRect . Left ;
MetafilePict ^. yExt := ExtRect . Top - ExtRect . Bottom ;
MetafilePict ^. HMF := FMetafileHandle ;
GlobalUnlock ( FClipboardHandle );
Result := FClipboardHandle ;
end ;
procedure TForm1 . BitBtn1Click ( Sender : TObject );
var
MetafileCanvas : TMetafileCanvas ;
begin
MetafileCanvas := TMetafileCanvas . Create ;
MetafileCanvas . Rect := Rect ( 0 , 0 , 500 , 500 );
MetafileCanvas . Ellipse ( 10 , 10 , 400 , 400 );
Image1 . Picture . Metafile . LoadFromClipboardFormat ( cf_MetafilePict , MetafileCanvas . MetafileHandle , 0 );
MetafileCanvas . Free ;
end ;
end .
3. Forma Bitmap kaplanmas ı...
var
Form1 : TForm1 ;
Bitmap : TBitmap ;
implementation
{$R *.DFM}
procedure TForm1 . FormCreate ( Sender : TObject );
begin
Bitmap := TBitmap . Create ;
Bitmap . LoadFromFile ( 'C:WINDOWShasir.bmp' );
end ;
procedure TForm1 . FormPaint ( Sender : TObject );
var
X , Y , W , H : LongInt ;
begin
with Bitmap do
begin
W := Width ;
H := Height ;
end ;
Y := 0 ;
while Y < Height do
begin
X := 0 ;
while X < Width do
begin
Canvas . Draw ( X , Y , Bitmap );
Inc ( X , W );
end ;
Inc ( Y , H );
end ;
end ;
end .
4.Transparan Bitmap nas ı l yap ı l ı r ...
procedure DrawTrans ( DestCanvas : TCanvas ; X , Y : smallint ; SrcBitmap : TBitmap ; AColor , BackColor : TColor );
var ANDBitmap , ORBitmap : TBitmap ;
CM : TCopyMode ;
Src : TRect ;
begin
ANDBitmap := NIL ;
ORBitmap := NIL ;
try
ANDBitmap := TBitmap . Create ;
ORBitmap := TBitmap . Create ;
Src := Bounds ( 0 , 0 , SrcBitmap . Width , SrcBitmap . Height );
with ORBitmap do begin
Width := SrcBitmap . Width ;
Height := SrcBitmap . Height ;
Canvas . Brush . Color := clBlack ;
Canvas . CopyMode := cmSrcCopy ;
Canvas . BrushCopy ( Src , SrcBitmap , Src , AColor );
end ;
with ANDBitmap do begin
Width := SrcBitmap . Width ;
Height := SrcBitmap . Height ;
Canvas . Brush . Color := BackColor ;
Canvas . CopyMode := cmSrcInvert ;
Canvas . BrushCopy ( Src , SrcBitmap , Src , AColor );
end ;
with DestCanvas do begin
CM := CopyMode ;
CopyMode := cmSrcAnd ;
Draw ( X , Y , ANDBitmap );
CopyMode := cmSrcPaint ;
Draw ( X , Y , ORBitmap );
CopyMode := CM ;
end ;
finally
ANDBitmap . Free ;
ORBitmap . Free ;
end ;
end ;
Kullan ı m ı :
DrawTrans ( Image2 . Canvas , 0 , 0 , 'C:Windowsdeepblue.bmp' , clBlack , clSilver );
Delphi - .....................................
Delphi -- Shareware İpuçları
Delphi -- Shareware İ pu ç lar ı
1 . Program ı n ı z her windows a çı l ışı nda sadece bir kere ç al ış s ı n ...
procedure TForm1 . FormShow ( Sender : TObject );
var atom : integer ;
CRLF : string ;
begin
if
GlobalFindAtom ( 'THIS_IS_SOME_OBSCUREE_TEXT' ) = 0 then
atom := GlobalAddAtom ( 'THIS_IS_SOME_OBSCUREE_TEXT' )
else
begin
CRLF := #10 + #13 ;
ShowMessage ( 'Bu versiyon her Windows oturumunda yanlızca bir kere çalışır.' + CRLF +
'Programı tekrar çalıştırmak için Windows' u restart edin . ' + CRLF +
'REGISTER !!' );
Close ;
end ;
end ;
Delphi - .....................................
Delphi -- Shareware İpuçları
Delphi -- Shareware İ pu ç lar ı
1 . Program ı n ı z her windows a çı l ışı nda sadece bir kere ç al ış s ı n ...
procedure TForm1 . FormShow ( Sender : TObject );
var atom : integer ;
CRLF : string ;
begin
if
GlobalFindAtom ( 'THIS_IS_SOME_OBSCUREE_TEXT' ) = 0 then
atom := GlobalAddAtom ( 'THIS_IS_SOME_OBSCUREE_TEXT' )
else
begin
CRLF := #10 + #13 ;
ShowMessage ( 'Bu versiyon her Windows oturumunda yanlızca bir kere çalışır.' + CRLF +
'Programı tekrar çalıştırmak için Windows' u restart edin . ' + CRLF +
'REGISTER !!' );
Close ;
end ;
end ;
Delphi - .....................................
Delphi -- WinAPI İpuçları
Delphi -- WinAPI İ pu ç lar ı
1.Windows 'un dial-up bağlantısının çağrılması
//modem yüklü olmalı
winexec ( PChar ( 'rundll32.exe rnaui.dll,RnaDial ' + Edit1 . Text ), sw_show );
2. Program ı na Animasyonlu Cursor Ekle
const
cnCursorID1 = 1 ;
begin
Screen . Cursors [ cnCursorID1 ] :=
LoadCursorFromFile (
'c:winntcursorspiano.ani' );
Cursor := cnCursorID1 ;
end ;
3.Programa E - mail linki eklemek
procedure email ;
var
x : string ;
begin
x := 'mailto:' + FEmailTo + '?Subject=' + FEmailSubject + '&cc=' + FEmailCC ;
ShellExecute ( 0 , nil , PChar ( x ), nil , nil , SW_SHOWDEFAULT );
end ;
4.Registry 'den Bilgi okumak
var
RegIni : TRegIniFile ;
begin
RegIni := TRegIniFile . Create ( '' );
with RegIni do
begin
RootKey := HKEY_LOCAL_MACHINE ;
LazyWrite := True ;
OpenKey ( 'SoftwareMicrosoftWindows' , False );
ShowMessage ( ReadString ( 'CurrentVersion' , 'RegisteredOrganization' , 'not assigned' ));
Free ;
end ;
end ;
5.A çı k b ü t ü n pencereleri listeleme
function EnumWindowsProc ( Wnd : HWnd ; Form : TForm1 ) : Boolean ; Export ; {$ifdef Win32} StdCall ; {$endif}
var
Buffer : Array [ 0 .. 99 ] of char ;
begin
GetWindowText ( Wnd , Buffer , 100 );
if StrLen ( Buffer ) <> 0 then
Form . ListBox1 . Items . Add ( StrPas ( Buffer ));
Result := True ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
EnumWindows (@ EnumWindowsProc , LongInt ( Self ));
end ;
Delphi - .....................................
Delphi -- WinAPI İpuçları
Delphi -- WinAPI İ pu ç lar ı
1.Windows 'un dial-up bağlantısının çağrılması
//modem yüklü olmalı
winexec ( PChar ( 'rundll32.exe rnaui.dll,RnaDial ' + Edit1 . Text ), sw_show );
2. Program ı na Animasyonlu Cursor Ekle
const
cnCursorID1 = 1 ;
begin
Screen . Cursors [ cnCursorID1 ] :=
LoadCursorFromFile (
'c:winntcursorspiano.ani' );
Cursor := cnCursorID1 ;
end ;
3.Programa E - mail linki eklemek
procedure email ;
var
x : string ;
begin
x := 'mailto:' + FEmailTo + '?Subject=' + FEmailSubject + '&cc=' + FEmailCC ;
ShellExecute ( 0 , nil , PChar ( x ), nil , nil , SW_SHOWDEFAULT );
end ;
4.Registry 'den Bilgi okumak
var
RegIni : TRegIniFile ;
begin
RegIni := TRegIniFile . Create ( '' );
with RegIni do
begin
RootKey := HKEY_LOCAL_MACHINE ;
LazyWrite := True ;
OpenKey ( 'SoftwareMicrosoftWindows' , False );
ShowMessage ( ReadString ( 'CurrentVersion' , 'RegisteredOrganization' , 'not assigned' ));
Free ;
end ;
end ;
5.A çı k b ü t ü n pencereleri listeleme
function EnumWindowsProc ( Wnd : HWnd ; Form : TForm1 ) : Boolean ; Export ; {$ifdef Win32} StdCall ; {$endif}
var
Buffer : Array [ 0 .. 99 ] of char ;
begin
GetWindowText ( Wnd , Buffer , 100 );
if StrLen ( Buffer ) <> 0 then
Form . ListBox1 . Items . Add ( StrPas ( Buffer ));
Result := True ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
EnumWindows (@ EnumWindowsProc , LongInt ( Self ));
end ;
Delphi - .....................................
Delphi -- File Yönetimi İpuçları
Delphi -- File Y ö netimi İ pu ç lar ı
1. Delphi 'de dosya nasıl Kopyalanır ?
Bunun i ç in bir ka ç y ö ntem var ...
Procedure FileCopy ( Const sourcefilename , targetfilename : String );
Var
S , T : TFileStream ;
Begin
S := TFileStream . Create ( sourcefilename , fmOpenRead );
try
T := TFileStream . Create ( targetfilename ,
fmOpenWrite or fmCreate );
try
T . CopyFrom ( S , S . Size ) ;
finally
T . Free ;
end ;
finally
S . Free ;
end ;
End ;
procedure FileCopy ( const FromFile , ToFile : string );
var
FromF , ToF : file ;
NumRead , NumWritten : Word ;
Buf : array [ 1 .. 2048 ] of Char ;
begin
AssignFile ( FromF , FromFile );
Reset ( FromF , 1 );
AssignFile ( ToF , ToFile );
Rewrite ( ToF , 1 );
repeat
BlockRead ( FromF , Buf , SizeOf ( Buf ), NumRead );
BlockWrite ( ToF , Buf , NumRead , NumWritten );
until ( NumRead = 0 ) or ( NumWritten <> NumRead );
CloseFile ( FromF );
CloseFile ( ToF );
end ;
{ USES LZExpand.}
procedure CopyFile ( FromFileName , ToFileName : string );
var
FromFile , ToFile : File ;
begin
AssignFile ( FromFile , FromFileName );
AssignFile ( ToFile , ToFileName );
Reset ( FromFile );
try
Rewrite ( ToFile );
try
if LZCopy ( TFileRec ( FromFile ). Handle , TFileRec ( ToFile ). Handle ) < 0 then
raise EInOutError . Create
finally
CloseFile ( ToFile );
end ;
finally
CloseFile ( FromFile );
end ;
end ;
2. Dosyan ı n de ğ i ş tirilme tarih ve saatinin öğ renilmesi
function GetModifiedDate ( FileName : string ): TDateTime ;
var
SearchRec : TSearchRec ;
ModifiedTime : TFileTime ;
SystemTime : TSystemTime ;
begin
Result := 0 ;
If FindFirst ( FileName , faAnyFile , SearchRec ) = 0 then
begin
ModifiedTime := SearchRec . FindData . ftLastWriteTime ;
FileTimeToLocalFileTime ( ModifiedTime , ModifiedTime );
FileTimeToSystemTime ( ModifiedTime , SystemTime );
Result := SystemTimeToDateTime ( SystemTime );
end ;
FindClose ( SearchRec );
end ;
3. Dosyan ı n varl ığı n ı n kontrol edilmesi
Function GetShortFileName ( Const FileName : String ) : String ;
var
aTmp : array [ 0 .. 255 ] of char ;
begin
if GetShortPathName ( PChar ( FileName ), aTmp , Sizeof ( aTmp )- 1 )= 0 then
Result := FileName + ' <--Bulunamadı'
else
Result := FileName + ' <--Bulundu' ;
end ;
4. Verilen bir dizinin i ç ini silme
procedure DelTree ( StartDir : string );
var
Search : TSearchRec ;
begin
if Startdir [ Length ( Startdir )] <> '' then
startdir := startdir + '' ;
if FindFirst ( startdir + '*.*' , faAnyFile , Search ) = 0 then
repeat
if ( Search . Name [ 1 ] <> '.' ) then
if (( Search . Attr and faDirectory ) > 0 ) then
begin
RmDir ( StartDir + Search . Name );
ChangeFAttrib ( StartDir + Search . Name );
end else
begin
DeleteFile ( StartDir + Search . Name );
Application . ProcessMessages ;
end ;
until FindNext ( Search ) <> 0 ;
FindClose ( Search );
end
Delphi - .....................................
Delphi -- File Yönetimi İpuçları
Delphi -- File Y ö netimi İ pu ç lar ı
1. Delphi 'de dosya nasıl Kopyalanır ?
Bunun i ç in bir ka ç y ö ntem var ...
Procedure FileCopy ( Const sourcefilename , targetfilename : String );
Var
S , T : TFileStream ;
Begin
S := TFileStream . Create ( sourcefilename , fmOpenRead );
try
T := TFileStream . Create ( targetfilename ,
fmOpenWrite or fmCreate );
try
T . CopyFrom ( S , S . Size ) ;
finally
T . Free ;
end ;
finally
S . Free ;
end ;
End ;
procedure FileCopy ( const FromFile , ToFile : string );
var
FromF , ToF : file ;
NumRead , NumWritten : Word ;
Buf : array [ 1 .. 2048 ] of Char ;
begin
AssignFile ( FromF , FromFile );
Reset ( FromF , 1 );
AssignFile ( ToF , ToFile );
Rewrite ( ToF , 1 );
repeat
BlockRead ( FromF , Buf , SizeOf ( Buf ), NumRead );
BlockWrite ( ToF , Buf , NumRead , NumWritten );
until ( NumRead = 0 ) or ( NumWritten <> NumRead );
CloseFile ( FromF );
CloseFile ( ToF );
end ;
{ USES LZExpand.}
procedure CopyFile ( FromFileName , ToFileName : string );
var
FromFile , ToFile : File ;
begin
AssignFile ( FromFile , FromFileName );
AssignFile ( ToFile , ToFileName );
Reset ( FromFile );
try
Rewrite ( ToFile );
try
if LZCopy ( TFileRec ( FromFile ). Handle , TFileRec ( ToFile ). Handle ) < 0 then
raise EInOutError . Create
finally
CloseFile ( ToFile );
end ;
finally
CloseFile ( FromFile );
end ;
end ;
2. Dosyan ı n de ğ i ş tirilme tarih ve saatinin öğ renilmesi
function GetModifiedDate ( FileName : string ): TDateTime ;
var
SearchRec : TSearchRec ;
ModifiedTime : TFileTime ;
SystemTime : TSystemTime ;
begin
Result := 0 ;
If FindFirst ( FileName , faAnyFile , SearchRec ) = 0 then
begin
ModifiedTime := SearchRec . FindData . ftLastWriteTime ;
FileTimeToLocalFileTime ( ModifiedTime , ModifiedTime );
FileTimeToSystemTime ( ModifiedTime , SystemTime );
Result := SystemTimeToDateTime ( SystemTime );
end ;
FindClose ( SearchRec );
end ;
3. Dosyan ı n varl ığı n ı n kontrol edilmesi
Function GetShortFileName ( Const FileName : String ) : String ;
var
aTmp : array [ 0 .. 255 ] of char ;
begin
if GetShortPathName ( PChar ( FileName ), aTmp , Sizeof ( aTmp )- 1 )= 0 then
Result := FileName + ' <--Bulunamadı'
else
Result := FileName + ' <--Bulundu' ;
end ;
4. Verilen bir dizinin i ç ini silme
procedure DelTree ( StartDir : string );
var
Search : TSearchRec ;
begin
if Startdir [ Length ( Startdir )] <> '' then
startdir := startdir + '' ;
if FindFirst ( startdir + '*.*' , faAnyFile , Search ) = 0 then
repeat
if ( Search . Name [ 1 ] <> '.' ) then
if (( Search . Attr and faDirectory ) > 0 ) then
begin
RmDir ( StartDir + Search . Name );
ChangeFAttrib ( StartDir + Search . Name );
end else
begin
DeleteFile ( StartDir + Search . Name );
Application . ProcessMessages ;
end ;
until FindNext ( Search ) <> 0 ;
FindClose ( Search );
end
Delphi - .....................................
Delphi -- Hardware İpuçları
Delphi -- Hardware İ pu ç lar ı
1. CD - ROM Drive 'ı kontrol etmek...
function IsCDROM ( DriveNum : Integer ): Boolean ; assembler ;
asm
MOV AX,1500h { MSCDEX 'e bakıyor}
XOR BX,BX
INT 2fh
OR BX,BX
JZ @Finish
MOV AX,150Bh { CD driver ın kullanılırlığına bakıyor}
MOV CX,DriveNum
INT 2fh
OR AX,AX
@Finish:
end ;
// Win32 kontrolörlü
A :
Function IsCdRom ( DriveNum : Word ) : Boolean ;
Var
F : WordBool ;
Begin
asm
mov ax, 1500h
xor bx, bx
int 2fh
mov ax, bx
or ax, ax
jz @no_mscdex
mov ax, 150bh
mov cx, DriveNum
int 2fh
@no_mscdex:
mov f,ax
end ;
Result := F ;
End ;
2. Disk veya Disket yerinde mi ?
function DiskInDrive ( Drive : Char ): Boolean ;
var
ErrorMode : word ;
begin
if Drive in [ 'a' .. 'z' ] then Dec ( Drive , $20 );
if not ( Drive in [ 'A' .. 'Z' ]) then
raise EConvertError . Create ( 'Not a valid drive ID' );
ErrorMode := SetErrorMode ( SEM_FailCriticalErrors );
try
{ sürücü 1 = a, 2 = b, 3 = c, etc. }
if DiskSize ( Ord ( Drive ) - $40 ) = - 1 then
Result := False
else
Result := True ;
finally
{ error moduna geri dön }
SetErrorMode ( ErrorMode );
end ;
end ;
3. Sistem Tarih ve Saatini de ğ i ş tirme ...
procedure SetDate ( Year , Month , Day : Word ); assembler ;
asm
MOV CX,Year
MOV DH,BYTE PTR Month
MOV DL,BYTE PTR Day
MOV AH,2BH
INT 21H
end ;
procedure SetTime ( Hour , Minute , Second , Sec100 : Word ); assembler ;
asm
MOV CH,BYTE PTR Hour
MOV CL,BYTE PTR Minute
MOV DH,BYTE PTR Second
MOV DL,BYTE PTR Sec100
MOV AH,2DH
INT 21H
end ;
function SetSystemDateTime ( Year , Month , Day , Hour , Minute , Second : word ): integer ; export ;
begin
SetDate ( Year , Month , Day );
SetTime ( Hour , Minute + 1 , Second , 0 );
result := 1 ;
end
Delphi - .....................................
Delphi -- Hardware İpuçları
Delphi -- Hardware İ pu ç lar ı
1. CD - ROM Drive 'ı kontrol etmek...
function IsCDROM ( DriveNum : Integer ): Boolean ; assembler ;
asm
MOV AX,1500h { MSCDEX 'e bakıyor}
XOR BX,BX
INT 2fh
OR BX,BX
JZ @Finish
MOV AX,150Bh { CD driver ın kullanılırlığına bakıyor}
MOV CX,DriveNum
INT 2fh
OR AX,AX
@Finish:
end ;
// Win32 kontrolörlü
A :
Function IsCdRom ( DriveNum : Word ) : Boolean ;
Var
F : WordBool ;
Begin
asm
mov ax, 1500h
xor bx, bx
int 2fh
mov ax, bx
or ax, ax
jz @no_mscdex
mov ax, 150bh
mov cx, DriveNum
int 2fh
@no_mscdex:
mov f,ax
end ;
Result := F ;
End ;
2. Disk veya Disket yerinde mi ?
function DiskInDrive ( Drive : Char ): Boolean ;
var
ErrorMode : word ;
begin
if Drive in [ 'a' .. 'z' ] then Dec ( Drive , $20 );
if not ( Drive in [ 'A' .. 'Z' ]) then
raise EConvertError . Create ( 'Not a valid drive ID' );
ErrorMode := SetErrorMode ( SEM_FailCriticalErrors );
try
{ sürücü 1 = a, 2 = b, 3 = c, etc. }
if DiskSize ( Ord ( Drive ) - $40 ) = - 1 then
Result := False
else
Result := True ;
finally
{ error moduna geri dön }
SetErrorMode ( ErrorMode );
end ;
end ;
3. Sistem Tarih ve Saatini de ğ i ş tirme ...
procedure SetDate ( Year , Month , Day : Word ); assembler ;
asm
MOV CX,Year
MOV DH,BYTE PTR Month
MOV DL,BYTE PTR Day
MOV AH,2BH
INT 21H
end ;
procedure SetTime ( Hour , Minute , Second , Sec100 : Word ); assembler ;
asm
MOV CH,BYTE PTR Hour
MOV CL,BYTE PTR Minute
MOV DH,BYTE PTR Second
MOV DL,BYTE PTR Sec100
MOV AH,2DH
INT 21H
end ;
function SetSystemDateTime ( Year , Month , Day , Hour , Minute , Second : word ): integer ; export ;
begin
SetDate ( Year , Month , Day );
SetTime ( Hour , Minute + 1 , Second , 0 );
result := 1 ;
end
Delphi - .....................................
Delphi -- String İpuçları
Delphi -- String İ pu ç lar ı
1. Editten sadece say ı m ı girilsin ...
procedure CheckText ( Sender : TEdit ; var Key : Char );
begin
If not ( Key in [ '0' .. '9' , '.' , #8 , #13 ]) then
Key := #0 ;
If Key = '.' then
begin
If Pos ( '.' , Sender . Text ) > 0 then
Key := #0 ;
end ;
end ;
2. Editin i ç ini belli bir formatta yazd ı rmak ...
Procedure Format ( MyEdit1 , MyEdit2 : TEdit );
Var
I : Integer ;
S : String ;
begin
I := StrToInt ( MyEdit1 . Text );
FmtStr ( S , '%.3d' , [ I ]);
MyEdit2 . Text := S ;
// I.E. If Edit1.Text := '1' den Edit2.Text := '001'; döndürür
end ;
3. String i ç inde belli iki karakter aras ı n ı almak ...
Function GetParsedItem ( TheItemStr , ParseStr : String ; ItemNum : Integer ): String ;
Var
I4 : Integer ;
S4 : String ;
Begin
TheItemStr := TheItemStr + ParseStr ;
S4 := '' ;
I4 := 0 ;
While I4 <= ItemNum Do
Begin
S4 := Copy ( TheItemStr , 1 , Pos ( ParseStr , TheItemStr ) - 1 );
Delete ( TheItemStr , 1 , Pos ( ParseStr , TheItemStr ));
Inc ( I4 );
End ;
Result := S4 ;
End ;
{TheItemStr de Parsestr ye bakiyor ve ItemNum inci parsestrden sonra tekrar bulana dek olan str yi veriyor.}
4. String ş ifreleme ...
function EnDeCode ( const Value : String ) : String ;
var
CharIndex : Integer ;
ReturnValue : String ;
begin
ReturnValue := '' ;
for CharIndex := 1 to Length ( Value ) do
begin
ReturnValue := ReturnValue + chr ( NOT ( ord ( Value [ CharIndex ])));
end ;
Result := ReturnValue ;
end ;
******************************************
Delphi - .....................................
Delphi -- String İpuçları
Delphi -- String İ pu ç lar ı
1. Editten sadece say ı m ı girilsin ...
procedure CheckText ( Sender : TEdit ; var Key : Char );
begin
If not ( Key in [ '0' .. '9' , '.' , #8 , #13 ]) then
Key := #0 ;
If Key = '.' then
begin
If Pos ( '.' , Sender . Text ) > 0 then
Key := #0 ;
end ;
end ;
2. Editin i ç ini belli bir formatta yazd ı rmak ...
Procedure Format ( MyEdit1 , MyEdit2 : TEdit );
Var
I : Integer ;
S : String ;
begin
I := StrToInt ( MyEdit1 . Text );
FmtStr ( S , '%.3d' , [ I ]);
MyEdit2 . Text := S ;
// I.E. If Edit1.Text := '1' den Edit2.Text := '001'; döndürür
end ;
3. String i ç inde belli iki karakter aras ı n ı almak ...
Function GetParsedItem ( TheItemStr , ParseStr : String ; ItemNum : Integer ): String ;
Var
I4 : Integer ;
S4 : String ;
Begin
TheItemStr := TheItemStr + ParseStr ;
S4 := '' ;
I4 := 0 ;
While I4 <= ItemNum Do
Begin
S4 := Copy ( TheItemStr , 1 , Pos ( ParseStr , TheItemStr ) - 1 );
Delete ( TheItemStr , 1 , Pos ( ParseStr , TheItemStr ));
Inc ( I4 );
End ;
Result := S4 ;
End ;
{TheItemStr de Parsestr ye bakiyor ve ItemNum inci parsestrden sonra tekrar bulana dek olan str yi veriyor.}
4. String ş ifreleme ...
function EnDeCode ( const Value : String ) : String ;
var
CharIndex : Integer ;
ReturnValue : String ;
begin
ReturnValue := '' ;
for CharIndex := 1 to Length ( Value ) do
begin
ReturnValue := ReturnValue + chr ( NOT ( ord ( Value [ CharIndex ])));
end ;
Result := ReturnValue ;
end ;
******************************************
Delphi - .....................................
Windows API Kullanımı ve Örnekler
Windows API Kullanı m ı ve Ö rnekler
Pocedur veya fonksiyon yazmadan da hyzly bir sekilde program yazylabilir delphide
Belgeler men ü s ü ne bir dosya ekleme
uses kysmyna ShlOBJ unitini ekleyin ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
s : string ;
begin
s := 'C:DownLoaddeneme.html' ;
SHAddToRecentDocs ( SHARD_PATH , pChar ( s ));
end ;
Belgeler men ü s ü n ü temizleme
uses kysmyna ShlOBJ unitini ekleyin ;
SHAddToRecentDocs ( SHARD_PATH , nil );
Duvar ka ? ydyny de ? i ? tirmek
var
s : string ;
begin
s := 'c:windowscars.bmp' ;
SystemParametersInfo ( SPI_SETDESKWALLPAPER , 0 , PChar ( s ), 0 );
End ;
Delphi - .....................................
Windows API Kullanımı ve Örnekler
Windows API Kullanı m ı ve Ö rnekler
Pocedur veya fonksiyon yazmadan da hyzly bir sekilde program yazylabilir delphide
Belgeler men ü s ü ne bir dosya ekleme
uses kysmyna ShlOBJ unitini ekleyin ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
s : string ;
begin
s := 'C:DownLoaddeneme.html' ;
SHAddToRecentDocs ( SHARD_PATH , pChar ( s ));
end ;
Belgeler men ü s ü n ü temizleme
uses kysmyna ShlOBJ unitini ekleyin ;
SHAddToRecentDocs ( SHARD_PATH , nil );
Duvar ka ? ydyny de ? i ? tirmek
var
s : string ;
begin
s := 'c:windowscars.bmp' ;
SystemParametersInfo ( SPI_SETDESKWALLPAPER , 0 , PChar ( s ), 0 );
End ;
Delphi - .....................................
Kendi Hazır Kodunu Oluşturma
Kendi Hazı r Kodunu Olu ş turma
delphide hep kod yazarken haz ı r kod ş ablonlar ı çı kar ö rn . showMes ... yazarken ş ablonda ShowMessage haz ı r çı k ı yor i ş te bunu kendi lehinize ç evire bilirsiniz .
Mesela msj yazarken haz ı r kod ş ablonunda Msg ( showMessage ) çı kmas ı i ç in :
Bunun i ç in Tools - Editor Options men ü se ç enekleri a çı lan Editor Properties
penceresinin Source Options sayfas ı na ge ç in . bu penceredeki Edit Code Templates d üğ mesini t ı klay ı n .
burada Add .. b ö l ü m ü ne Shortcut Name : msj
Description : Mesaj Kutusu Ok .
bundan sonra Code k ı sm ı na ş ablona ait kodu yaz ı n ...
i ş te kod yazarken Msj yazd ığı n ı zda otomatik olarak Msj çı kacak ve kod
ShowMessage ( '' ); olarak gelecek ...
Delphi - .....................................
Kendi Hazır Kodunu Oluşturma
Kendi Hazı r Kodunu Olu ş turma
delphide hep kod yazarken haz ı r kod ş ablonlar ı çı kar ö rn . showMes ... yazarken ş ablonda ShowMessage haz ı r çı k ı yor i ş te bunu kendi lehinize ç evire bilirsiniz .
Mesela msj yazarken haz ı r kod ş ablonunda Msg ( showMessage ) çı kmas ı i ç in :
Bunun i ç in Tools - Editor Options men ü se ç enekleri a çı lan Editor Properties
penceresinin Source Options sayfas ı na ge ç in . bu penceredeki Edit Code Templates d üğ mesini t ı klay ı n .
burada Add .. b ö l ü m ü ne Shortcut Name : msj
Description : Mesaj Kutusu Ok .
bundan sonra Code k ı sm ı na ş ablona ait kodu yaz ı n ...
i ş te kod yazarken Msj yazd ığı n ı zda otomatik olarak Msj çı kacak ve kod
ShowMessage ( '' ); olarak gelecek ...
Delphi - .....................................
Programın Windowsta Bir Kere Çalışmasını Sağlar
Program ı n Windowsta Bir Kere Ç al ış mas ı n ı Sa ğ lar
A ş a ğı daki prosed ü r yazd ığı n ı z program ı n her windows oturumunda yaln ı z birkez ç al ış mas ı n ı sa ğ lar . Program ı ayn ı windows oturumunda ikinci kez ç al ış t ı rd ığı n ı zda program < MessageStr > de ğ i ş kenine girece ğ iniz mesaj ı vererek sonlanacakt ı r ...
procedure RunOnceForEveryWindowsSession ( MessageStr : String );
var
My_Atom : Integer ;
begin
if GlobalFindAtom ( 'Buraya_Birseyler_Yazin' ) = 0 then
My_Atom := GlobalAddAtom ( 'Buraya_Birseyler_Yazin' )
else
begin
ShowMessage ( MessageStr );
Application . Terminate ;
end ;
end ;
Delphi - .....................................
Programın Windowsta Bir Kere Çalışmasını Sağlar
Program ı n Windowsta Bir Kere Ç al ış mas ı n ı Sa ğ lar
A ş a ğı daki prosed ü r yazd ığı n ı z program ı n her windows oturumunda yaln ı z birkez ç al ış mas ı n ı sa ğ lar . Program ı ayn ı windows oturumunda ikinci kez ç al ış t ı rd ığı n ı zda program < MessageStr > de ğ i ş kenine girece ğ iniz mesaj ı vererek sonlanacakt ı r ...
procedure RunOnceForEveryWindowsSession ( MessageStr : String );
var
My_Atom : Integer ;
begin
if GlobalFindAtom ( 'Buraya_Birseyler_Yazin' ) = 0 then
My_Atom := GlobalAddAtom ( 'Buraya_Birseyler_Yazin' )
else
begin
ShowMessage ( MessageStr );
Application . Terminate ;
end ;
end ;
Delphi - .....................................
İki tarih arası filtreleme
Table1. Filtered := False ;
Table1 . Filter :=
'([Mgz G Tarihi]>=' + #39 + DateToStr ( islemdate1 . Date )+ #39 + ' and ' +
'[Mgz G Tarihi]<=' + #39 + DateToStr ( islemdate2 . Date )+ #39 + ')' ;
Table1 . Filtered := True ;
{eğer fieldnameiniz benimkinde olduğu gibi boşluklardan oluşuyorsa köşeli
parantez'[Mgz G Tarihi]<='koyun bir çok arkadaşın düştüğü hata bu yok eğer
boşluk yok tek bir kelime ise'Mgz G Tarihi<=' gibi gerek yok kolay gelsin
Delphi - .....................................
İki tarih arası filtreleme
Table1. Filtered := False ;
Table1 . Filter :=
'([Mgz G Tarihi]>=' + #39 + DateToStr ( islemdate1 . Date )+ #39 + ' and ' +
'[Mgz G Tarihi]<=' + #39 + DateToStr ( islemdate2 . Date )+ #39 + ')' ;
Table1 . Filtered := True ;
{eğer fieldnameiniz benimkinde olduğu gibi boşluklardan oluşuyorsa köşeli
parantez'[Mgz G Tarihi]<='koyun bir çok arkadaşın düştüğü hata bu yok eğer
boşluk yok tek bir kelime ise'Mgz G Tarihi<=' gibi gerek yok kolay gelsin
Delphi - .....................................
Delphi ipuçları ( toplu olarak )
PARADOX ve dBASE VERİ TABANLARININ A Ğ Ü ZER İ NDE KULLANIMI
Paradox ve Dbase tablolar ı n ı a ğ da ç al ış t ı rabilmek i ç in A ş a ğı daki BDE ayarlar ı n ı Kullan ı n .
ANA MAK İ NA AYARLARI
Ana Makina Ad ı: Server
Disk payla şı m ad ı : C
Paradox veya dBASE tablolar ı n ı n bulundu ğ u Klas ö r c : Prog Data
PDOXUSRS . NET dosyas ı n ı n yeri : c :
Ana Makina BDE Ayarlar ı:
DataBAse sekmesi :
Alias : MyProg
Path : c : Prog Data
Congiguration -> Drivers -> Native -> PARADOX ( veya dBASE ) sekmesi :
NET DIR : C : ( PDOXUSRS . NET dosyas ı n ı g ö sterecek )
LANGDRIVER : paradox " turk "
Congiguration -> System -> INIT sekmesi :
LANGDRIVER : paradox " turk "
LOCALSHARE : TRUE
TERM İ NAL MAK İ NA BDE AYARLARI :
DataBAse sekmesi :
Alias : MyProg
Path : Server Prog Data
Congiguration -> Drivers -> Native -> PARADOX ( veya dBASE ) sekmesi :
NET DIR : Server c ( Ana makinadaki PDOXUSRS . NET dosyas ı n ı g ö sterecek )
LANGDRIVER : paradox " turk "
Congiguration -> System -> INIT sekmesi :
LANGDRIVER : paradox " turk "
LOCALSHARE : TRUE
Yukarda anlat ı lan ayarlaR ı n d ışı nda ş ayet terminalden ana makina i ç in bir a ğ yolu tan ı mlam ış san ı z terminal ayarlar ı a ş a ğı daki gibi de olabilir .
Ana makinan ı n diskine F diye bir a ğ yolu tan ı mlad ı ysak ayarlar ş u ş ekilde olacakt ı r .
DataBase sekmesi :
Alias : MyProg
Path : F : Prog Data
Congiguration -> Drivers -> Native -> PARADOX ( veya dBASE ) sekmesi :
NET DIR : F : ( Ana makinadaki PDOXUSRS . NET dosyas ı n ı g ö sterecek )
LANGDRIVER : paradox " turk "
Congiguration -> System -> INIT sekmesi :
LANGDRIVER : paradox " turk "
LOCALSHARE : TRUE
Ancak bu tan ı mda dikkat edilmesi gereken ş ey F a ğ yolu koptu ğ unda program ç al ış mayacakt ı r . . exe dosyan ı z ı terminalden istedi ğ iniz klas ö rden ç al ış t ı rabilirsiniz .
****************************************** DELPHI İ PU Ç LARI VE KODLARI
Alt + F4 tu ş kombinasyonuyla program ı n kapanmamas ı i ç in
Formun OnCreate olay ı na ; KeyPreview := true ;
Formun OnKeyDown olay ı na ; if (( ssAlt in Shift ) and ( Key = VK_F4 )) then
Key := 0 ;
Bir string 'in başındaki ve sonundaki boşlukları atmak için
Trim ( string ) rimLeft ( string ) //stringin sadece başındaki boşlukları atmak için TrimRight (string) //stringin sadece sonundaki boşlukları atmak için
Listbox 'a, Memo' ya ve Combobox 'a bir seferde birden çok eleman eklemek
Listbox1 . items . SetText ( 'Ali' #13 'Veli' #13 'kırkdokuzelli' );
Memo1 . Lines . SetText ( 'Ali' #13 'Veli' #13 'kırkdokuzelli' );
Combobox1 . items . SetText ( 'Ali' #13 'Veli' #13 'kırkdokuzelli' );
Memo i ç inde imlecin hangi sat ı r ve kolonda oldu ğ unu bulma
var
LineNum : logint ;
CharsBeforeLine : logint ;
begin
LineNum := SendMessage ( Memo1 . Handle , EM_LINEFROMCHAR , Memo1 . SelStart , 0 );
CharsBeforeLine := SendMessage ( Memo1 . Handle , EM_LINEINDEX , LineNum , 0 );
Label1 . Caption := 'Satır' + IntToStr ( LineNum + 1 );
Label2 . Caption := 'Kolon' + IntToStr (( Memo1 . SelStart - CharsBeforeLine )+ 1 );
ListBox veya ComboBox 'ta seçili bir veya birden fazla öğeyi
se ç ilmemi ş hale getirme
ListBox1 . ItemIndex :=- 1 ;
Combobox1 . ItemIndex :=- 1 ;
Bir men ü öğ esini kullan ı lamaz hale getirmek
MainMenu1 . Items [ 0 ]. Items [ 1 ]. Enabled := False ; //ilk menünün, ikinci elemanı
Edit 'e sadece sayı girilsin
Bir edit 'e sadece istediğiniz karakterlerin girilmesini sağlayabilirsiniz.
Bunun i ç in Edit 'in OnKeyPress olayına aşağıdaki kodu yazın.
if not ( key in [ '0' .. '9' , #8 ]) then
begin
Key := #0 ; //girilen karakter rakam veya backspace değilse null(#0)'a dönüştür
Beep ; //bip sesi ile kullanıcıyı uyar.
end ;
NOT : Kullan ı c ı Edit 'e rakamların dışında karakter giremez, ancak Paste ile Edit' e bir
metni kopyalayabilir . Bunuda Edit 'in OnExit olayında kontrol edip, girilen değerin
istedi ğ iniz ş ekilde olup olmad ığı n ı kontrol edebilirsiniz .
Bir Popup men ü y ü kod ile g ö sterme
PopupMenu1 . Popup ( Form1 . Left + 60 , Form1 . Top + 140 );
Sistem tarihini ve saatini de ğ i ş tirmek
Sistemin tarihini ve saatini de ğ i ş tirmek i ç in SetLocalTime fonksiyonunu
kullanabilirsiniz .
var
t : TSystemTime ;
begin
t . wYear := 1998 ; t . wMonth := 5 ; t . wDay := 23 ; t . wHour := 12 ; t . wMinute := 34 ;
SetLocalTime ( t );
end ;
Say ı lar ı virg ü llerle yazmak
Bu i ş i ç in FormatFloat fonksiyonunu kullanabilirsiniz . Say ı windows 'unuz ayarına
g ö re 12.345.678 veya 12 , 345 , 678 ş eklinde g ö sterilir .
procedure TForm1 . Button1Click ( Sender : TObject );
var
i : integer ;
begin
i := 12345678 ;
Memo1 . Lines . Add ( FormatFloat ( '#,' , i ));
Edit 'e girilen metnin ilk harfini büyük harf yapma
Bunun i ç in Edit 'in OnKeyPress olayına aşağıdaki kodu ekleyin.
with Sender as TEdit do
if ( SelStart = 0 ) or
( Text [ SelStart ] = ' ' ) then
if Key in [ 'a' .. 'z' ] then
Key := UpCase ( Key );
Fareyi me ş gul ş ekilde g ö stermek
Bir i ş lem yaparken makinenin me ş gul oldu ğ unu g ö stermek i ç in fareyi kum saati
ş eklinde g ö sterip sonra eski haline getirmek i ç in a ş a ğı daki gibi bir kod
kullanabilirsiniz .
try
Screen . Cursor := crHourGlass ;
{buraya kodunuzu yazın...}
finally
Screen . Cursor := crDefault ;
end ;
Application . ProcessMessages ;
Ç ok Sat ı rl ı İ pucu
procedure TForm1 . FormCreate ( Sender : TObject );
begin
SpeedButton1 . Hint := 'Çok satırlı ipucunu ' + chr ( 13 )+
'mutlaka denemelisiniz ' + chr ( 13 )+ 'çok güzel' ;
end ;
Form 'un arka kısmına bir resmi döşemek
Bitmap : TBitmap ;
procedure TForm1 . FormCreate ( Sender : TObject );
begin
Bitmap := TBitmap . Create ;
Bitmap . LoadFromFile ( 'C:WINDOWScars.BMP' );
end ; procedure TForm1 . FormPaint ( Sender : TObject ); var X , Y , W , H : LongInt ; begin with Bitmap do begin W := Width ; H := Height ; end ; Y := 0 ; while Y < Height do begin X := 0 ; while X < Width do begin Canvas . Draw ( X , Y , Bitmap ); Inc ( X , W ); end ; Inc ( Y , H ); end ; end ;
Hareketli İ mle ç( animated cursor ) leri kullanma
procedure TForm1 . Button1Click ( Sender : TObject );
var
h : THandle ;
begin h := LoadImage ( 0 , 'C:TheWallMagic.ani' , IMAGE_CURSOR , 0 , 0 , LR_DEFAULTSIZE orLR_LOADFROMFILE ); if h = 0 then ShowMessage ( 'Cursor not loaded' ) else begin Screen . Cursors [ 1 ] := h ; Form1 . Cursor := 1 ; end ; end ;
S ü r ü c ü n ü n kapasitesini ve s ü r ü c ü deki bo ş yer miktar ı n ı bulmak
DiskFree ( 0 ) //o anki sürücüdeki boş yer miktarını byte cinsinden döndürür.
DiskSize ( 0 ) //o anki sürücünün kapasitesini byte cinsinden döndürür.
DiskSize ( 0 ) div 1024 //o anki sürücünün kapasitesini KB cinsinden döndürür.
Bir form ü zerindeki t ü m bile ş enleri read only ( salt okunur ) yapma
uses k ı sm ı na typinfo unitini ekleyin .
procedure TForm1 . SetReadOnly ( Value : boolean ) ;
var
PropInfo : PPropInfo ;
Component : TComponent ;
i : integer ;
begin
for i := 0 to ComponentCount - 1 do begin
Component := Components [ i ] ;
if Component is TControl then begin
PropInfo := GetPropInfo ( Component . ClassInfo , 'ReadOnly' ) ;
if Assigned ( PropInfo ) and
( PropInfo ^. PropType ^. Kind = tkEnumeration ) then
SetOrdProp ( Component , PropInfo , integer ( Value ) ) ;
end ;
end ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
SetReadOnly ( true ) ;
end ;
