Dikey Başlık
type
TForm1 = class ( TForm )
procedure FormResize ( Sender : TObject );
procedure FormPaint ( Sender : TObject );
private
procedure VerticalTitleBar ( Texto : string ; Size : Integer );
end ;
const
MY_TITLE_TEXT = 'Ne Mutlu Türküm Diyene' ;
var
Form1 : TForm1 ;
implementation
{$R *.DFM}
procedure TForm1 . VerticalTitleBar ( TexTo : string ; Size : Integer );
var
LogFont : TLogFont ;
tmpCanvas : TCanvas ;
tmpRect : TRect ;
x1 , x2 , y1 , y2 : integer ;
begin
tmpCanvas := TCanvas . Create ;
tmpCanvas . Handle := GetWindowDc ( Handle );
try
GetObject ( Canvas . Font . Handle , SizeOf ( LogFont ), @ LogFont );
with LogFont do
begin
lfEscapement := 90 * 10 ;
lfOrientation := 90 * 10 ;
lfOutPrecision := OUT_TT_ONLY_PRECIS ;
lfFaceName := 'Arial' ;
lfHeight := Size ;
lfWeight := FW_BOLD ;
lfQuality := PROOF_QUALITY ;
end ;
with tmpCanvas do
begin
Font . Handle := CreateFontIndirect ( LogFont );
Font . Color := clWhite ;
Brush . Color := clRed ;
end ;
x1 := GetSystemMetrics ( SM_CXEDGE ) + GetSystemMetrics ( SM_CXBORDER );
x2 := 20 ;
y1 := GetSystemMetrics ( SM_CYCAPTION ) + GetSystemMetrics ( SM_CYEDGE ) +
GetSystemMetrics ( SM_CYBORDER ) + 1 ;
y2 := Height - GetSystemMetrics ( SM_CYEDGE ) - GetSystemMetrics ( SM_CYBORDER );
tmpRect := Rect ( x1 , y1 , x2 , y2 );
tmpCanvas . FillRect ( tmpRect );
DrawText ( tmpCanvas . Handle , PChar ( Texto ), - 1 , tmpRect , DT_BOTTOM or
DT_SINGLELINE );
finally
tmpCanvas . Free ;
end ;
end ;
procedure TForm1 . FormResize ( Sender : TObject );
begin
VerticalTitleBar ( MY_TITLE_TEXT , 12 );
end ;
procedure TForm1 . FormPaint ( Sender : TObject );
begin
VerticalTitleBar ( MY_TITLE_TEXT , 12 );
end ;
end .
Delphi - .....................................
Open Save Dialog
procedure TForm1 . Button1Click ( Sender : TObject );
begin
with AgOpenDialog1 do
try
Execute ;
finally
end;
end ;
procedure TForm1 . Button2Click ( Sender : TObject );
begin
with AgSaveDialog1 do
try
Execute ;
finally
end;
end ;
procedure TForm1 . CheckBox1Click ( Sender : TObject );
begin
AgOpenDialog1 . ShowPlacesBar := ( Sender as TCheckBox ). Checked ;
AgSaveDialog1 . ShowPlacesBar := ( Sender as TCheckBox ). Checked ;
end ;
end .
Delphi - .....................................
Animasyonlu Açılışlar
procedure TForm1 . Button1Click ( Sender : TObject );
begin
// The first part it for the handle of a window the second is if you want it to go negative or positive the last part th the action you want to have like hide then slide out etc enjoy
AnimateWindow ( Form1 . Handle , 1000 , AW_HOR_POSITIVE or AW_HOR_NEGATIVE or AW_Hide );
AnimateWindow ( Form1 . Handle , 1000 , AW_HOR_POSITIVE or AW_HOR_NEGATIVE or AW_CENTER );
AnimateWindow ( Form1 . Handle , 1000 , AW_HOR_NEGATIVE or AW_HOR_POSITIVE or AW_Hide );
AnimateWindow ( Form1 . Handle , 1000 , AW_HOR_POSITIVE or AW_HOR_NEGATIVE or AW_SLIDE );
AnimateWindow ( Form1 . Handle , 1000 , AW_VER_POSITIVE or AW_HIde );
AnimateWindow ( Form1 . Handle , 1000 , AW_VER_NEGATIVE or AW_SLIDE );
end ;
end .
procedure TForm2 . FormShow ( Sender : TObject );
begin
AnimateWindow ( Self . Handle , 250 , AW_HOR_POSITIVE or AW_ACTIVATE );
end ;
procedure TForm3 . FormShow ( Sender : TObject );
begin
AnimateWindow ( Self . Handle , 250 , AW_VER_POSITIVE or AW_ACTIVATE );
end ;
procedure TForm4 . FormShow ( Sender : TObject );
begin
AnimateWindow ( Self . Handle , 250 , AW_CENTER or AW_ACTIVATE );
end ;
Delphi - .....................................
Formlara Zoom Efekti
type
TZHar =
(syKapat , syAc );
procedure ZEfek ( OForm : TForm ; islem : TZHar );
var
SStart : TRect ;
SEnd : TRect ;
STray : TRect ;
wndTray : hWnd ;
wndChild : hWnd ;
begin
wndTray := FindWindow ( 'Shell_TrayWnd' , nil );
wndChild := FindWindowEx ( wndTray , 0 , 'TrayNotifyWnd' , nil );
GetWindowRect ( wndChild , STray );
if islem = syKapat then
begin
SStart := OForm . BoundsRect ;
SEnd := STray ;
end
else
begin
SEnd := OForm . BoundsRect ;
SStart := STray ;
end ;
//sihir burda gerçekleşiyor
DrawAnimatedRects ( OForm . Handle , IDANI_CAPTION , SStart , SEnd )
end ;
procedure TForm1 . FormClose ( Sender : TObject ; var Action : TCloseAction );
begin
ZEfek ( Self , syKapat );
end ;
procedure TfrmTest . FormShow ( Sender : TObject );
begin
ZEfek ( Self , syAc );
end ;
Delphi - .....................................
Saydam Form
procedure
TForm1 . FormCreate ( Sender :
TObject );
var
MyRgn ,
ClientRgn ,
ButtonRgn :
THandle ;
Margin , X , Y :
Integer ;
begin
Margin := ( Width - ClientWidth ) div 2 ;
MyRgn := CreateRectRgn ( 0 , 0 , Width , Height );
X := Margin ;
Y := Height - ClientHeight - Margin ;
ClientRgn := CreateRectRgn ( X , Y , X + ClientWidth , Y + ClientHeight );
CombineRgn ( MyRgn , MyRgn , ClientRgn , RGN_XOR );
X := X + Button1 . Left ;
Y := Y + Button1 . Top ;
ButtonRgn := CreateRectRgn ( X , Y , X + Button1 . Width , Y + Button1 . Height );
//-----------!!-----------
CombineRgn ( MyRgn , MyRgn , ButtonRgn , RGN_XOR );
SetWindowRgn ( Handle , MyRgn , True );
end ;
Delphi - .....................................
Kod Yazma
procedure TForm1 . Button1 . Click ( Sender : TObject );
begin //Ekle butonuna yazılacak kod
Listbox1 . Items . Add ( Edit1 . Text + ' ' + Edit2 . Text + ' ' + Edit3 . Text + ' ' + ComboBox1 . Text + '
'Combobox2.Text);
end ;
procedure TForm1 . Button2 . Click ( Sender : TObject );
begin // Sil Düğmesi
ListBox1 . Items . Delete ( ListBox1 . ItemIndex );
end ;
procedure TForm1 . Button3 . Click ( Sender : TObject );
begin // Kaydet düğmesi
ListBox1 . Items . SaveToFile ( 'liste.dat' ); //Liste adlı dosya oluşturarak bilgiyi kaydeder.
end ;
procedure TForm1 . Button4 . Click ( Sender : TObject );
begin // Yükle düğmesi
ListBox1 . Items . LoadFromFile ( 'liste.dat' ); // Bilgileri Listbox1'e yükler.
end ;
procedure TForm1 . Button5 . Click ( Sender : TObject );
begin // Programı kapatma düğmesi
Close ;
end ;
Delphi - .....................................
Delphide Kullanılan Operatörler
Operatö r A çı klama Ö rnek
+ Toplama a := b + c ;
- Çı karma a := b - c ;
* Ç arpma a := b * c ;
/ B ö lme a := b / c ;
Div Tamsay ı B ö lme a := b div 10 ;
:= Atama a := 12 ;
= E ş ittir if ( a = 12 ) then ShowMessages ( 'a eşit 12' );
< > E ş it De ğ il if ( a < > 12 ) then ShowMessages ( 'a eşit değil 12' );
< K üçü k if ( a < 12 ) then ShowMessages ( 'a küçük 12' );
> B ü y ü k if ( a > 12 ) then ShowMessages ( 'a büyük 12' );
>= B ü y ü k e ş it if ( a >= 12 ) then ShowMessages ( 'a büyük eşit 23' );
<= K üçü k e ş it if ( a <= 12 ) then ShowMessages ( 'a küçük eşit 23' );
And Mant ı ksal AND if ( a >= 12 ) and ( a < 15 ) then ShowMessages ( 'a değerleri gerçekleşti);
Or Mant ı ksal Or if ( a > 12 ) or ( a < 15 ) then ShowMessages ( 'a değerinin İkisi veya
biri ger ç ekle ş ti . ');
Not Mant ı ksal Not if not ( a < 12 ) then ShowMessages ( 'a değeri 12' den b ü y ü k
de ğ il . ');
^ Pointer Operat ö r ü a := b * c ^;
@ Pointer Adresi a :=@ b ;
$ Heksadecimal Operat ö r ü
a := $FF ;
[] Dizi Operat ö r ü a : Array [ 1 .. 99 ] of integer ;
. Nokta Operat ö r ü Personelin . Ad ı:= 'Bahadir' ;
Delphi - .....................................
Delphide Döngüler
İ f D ö ng ü s ü
if d ö ng ü s ü n ü n genel yap ı s ı a ş a ğı daki gibidir .
If ş art then
Komut ;
Else
di ğ er komut ;
Ö rnek : var
i : integer ;
begin
i := 0 ;
i := i + 1 ;
if i = 1 then begin
Label1 . Caption := 'Doğru ' ;
end
else
if i <> 1 then begin
Label1 . Caption := 'Yanlış ' ;
end ;
end ;
Case D ö ng ü s ü
Bir de ğ i ş kenin ald ığı bir ç ok de ğ ere g ö re ayr ı komutlar ı n ç al ış t ı r ı lmas ı gereken durumlarda
Case d ö ng ü s ü kullan ı l ı r . Genel yap ı s ı a ş a ğı daki gibidir .
Case de ğ i ş ken of
durum1 : Komutlar ;
durum2 : Komutlar ;
......
durumn : komutlar ;
Else komutlar ;
end ;
Yukarda dikkat edilirse de ğ i ş ken ; durumlara uyan de ğ erler ald ığı zaman ilgili komutlar ç al ış acak
e ğ er de ğ i ş kenin de ğ eri hi ç birine uymuyorsa Else ' den sonraki komut çalışacaktır.
A ş a ğı daki ö rne ğ i inceleyelim .
Case x of
1 : label1 . Caption := ' Merhaba ' ;
2 : label1 . Caption := ' Dünya ' ;
3 : Edit1 . Text := ' Bahadir Sahin ' ;
else
Edit1 . Text := ' Hoşçakal ' ;
end ;
For D ö ng ü s ü
For d ö ng ü s ü n ü n genel yap ı s ı a ş a ğı daki gibidir .
For i := ilkde ğ er to sonde ğ er do
begin
komut ;
end ;
Burada to kullan ı ld ığı i ç in i artarak de ğ erler al ı r . downto kullan ı ld ığı zaman de ğ er i de ğ erleri
azalarak gider .
For i := ilkde ğ er downto sonde ğ er do
begin
komut ;
end ;
Ö rnek : var
i : array [ 1 .. 20 ] of string ;
k : integer ;
begin
for i := 1 to 20 do
i [ k ] := InputBox ( ' i değer girişi ' , Inttostr ( k ) + '.nin adı ' , ' ' ) ;
end ;
While - Do D ö ng ü s ü
Bir ş art ger ç ekle ş ti ğ i zaman ç al ış mas ı gereken program bloklar ı nda kullan ı l ı r . Genel yap ı s ı
a ş a ğı daki gibidir .
While ş art do
Begin
Komutlar ;
end ;
Ö rnek : var
i : integer ;
Begin
i := 0 ;
while i < 10 do
Begin
Label1 . Caption := inttostr ( i ) ;
i := i + 1 ;
end ;
Repeat - Until D ö ng ü s ü
Genel yap ı s ı a ş a ğı daki gibidir . Ş art ger ç ekle ş ene kadar ç al ış mas ı gereken k ı s ı mlarda kullan ı l ı r .
Repeat
Komut ;
Until Ş art ;
Ö rnek : var
i : integer ;
begin
repeat
i := 50 ;
Until ( i > 0 ) and ( i < 50 )
end ;
D ö ng ü Kontrol İ fadeleri
Baz ı durumlarda d ö ng ü bitmeden d ö ng ü den çı k ı lmak istenebilir . Bu gibi durumlarda d ö ng ü
kontrol deyimlerini kullanmak gerekir . Bunlardan baz ı lar ı Break , Continue gibi deyimlerdir .
Break
Break kontrol deyimi For , While veya Repeat d ö ng ü lerinden birinde d ö ng ü den çı kmak i ç in
kullan ı l ı r . A ş a ğı daki ö rne ğ i inceleyelim .
Ö rnek : procedure TForm1 . Button1 . Click ( Sender : TObject ) ;
var
i : array [ 1 .. 20 ] of string ;
k : integer ;
begin
for i := 1 to 20 do
if i [ k ] = 'Bahadir' then begin
break ;
if > 50 then begin
ShowMessages ( ' Aranan kayıt bulunamadı. Tekrar deneyiniz...' ) ;
end
else
ShowMessages ( Inttostr ( k ) + ' . kişi' ) ;
end ;
end ;
Continue
Continue ; For , While veya Repeat d ö ng ü lerinde baz ı ş artlar ger ç ekle ş ti ğ inde d ö ng ü n ü n sonuna
gitmeden tekrar ba ş a d ö nmesini sa ğ lar .
Ö rnek : var
i : integer ;
Begin
for i := 1 to 20 do
if i < 10
continue ;
end ;
ShowMessages ( Inttostr ( i ) ) ;
end ;
Exit
Exit ; mevcut program blo ğ undan , blo ğ un sonuna ula ş madan çı kmaya yarar .
Ö rnek : var i : integer ;
begin
i := strtoint ( Edit1 . Text ) ;
if i < 10 then begin
exit ;
end
else
Edit1 . Text := 'i' nin de ğ erleri 10 'dan büyük.' ;
end ;
end ;
Halt
Programdan çı k ış sa ğ lar .
Ö rnek : Begin
Form1 . Halt ; // Programdan çıkış sağlar.
end ;
Whit - Do
Herhangi bir kontrol eleman ı n ı n birden fazla ö zelli ğ ini de ğ i ş tirmek i ç in yada metodlara ula ş mak
i ç in kullan ı l ı r . Genel kullan ı m ı m ş ekli a ş a ğı daki gibidir .
With kontroladi do
Begin
....
end ;
Delphi - .....................................
Veri Sorgulama
TQuery Kontrolü İ le Veri Sorgulama
Delphi 'de Veri Sorgulama işlemi TQuery kontrolü ile olur. TQuery kontrolüne ait SQL özelliği;
hem bir edit ö r olarak ve hem de do ğ rudan SQL komutlar ı yaz ı l ı p ç al ış t ı r ı lmak suretiyle
kullan ı lan bir ö zelliktir . Ş imdi Query1 kontrol ü yle sorgulama i ş lemlerine ba ş layal ı m .
T ü m S ü tunlar ı Listelemek
A ş a ğı daki ö rne ğ i inceleyelim .
Ö rnek : liste . dbf adl ı veri taban ı m ı z olsun . Bunu Query1 kontrol ü ile sorgulay ı p listelemek
istiyoruz . Bunun i ç in yapmam ı z gerekenler ş unlard ı r . İ lk ö nce formumuza Data Access
k ı sm ı ndan Query1 bile ş eni ile DataSource1 bile ş eni yerle ş tirelim . DataSource1 'in Dataset
ö zelli ğ ini Query1 yapal ı m . Daha sonra Data Controls k ı sm ı ndan formumuza DbGrid yerle ş tirelim
ve Object Inspector 'den DataSource özelliğini DataSource1 yapalım. Daha sonra
Query1 'in DataBaseName özelliğini alias olarak tanımlanan önceden oluşturduğumuz liste.
dbf 'yi seçelim. Sonra Query1' in SQL ö zelli ğ ine gidip çı kan pencerede a ş a ğı daki SQL ifadesini
yazal ı m .
SELECT * FROM liste
Sonra Query1 'in Object Inspector' den Active ö zelli ğ ini True yapal ı m ve program ı m ı z ı F9 'a
basarak ç al ış t ı ral ı m . DbGrid 'de görüleceği gibi liste.dbf' deki b ü t ü n bilgiler listenmi ş tir .
İ stenilen S ü tunlar ı Listelemek
istenilen s ü tunlar listelenmek istenirse Query1 'in SQL özelliğine şu SQL komutu yazılmalıdır.
SELECT adi , soyadi , adresi FROM liste
Not : liste . dbf adl ı veri taban ı m ı zdan sadece adi , soyadi , adresi adl ı s ü tunlar ve bu s ü tunlardaki
bilgileri listelemi ş olduk .
Tekrarl ı Kay ı tlar ı Bir Defa Listelemek
Bir tabloda bulunan ayn ı kay ı tlar ı bir kez listelemek i ç in DISTINCT komutu kullan ı l ı r . Bunun
i ç in ; Query1 'in SQL özelliğine şu SQL komutu yazılmalıdır.
SELECT DISTINCT adi , soyadi , adresi FROM liste
Ş artl ı Sorgulama yapmak istersek a ş a ğı daki gibi SQL komutu kullanmak gerekir .
SELECT adi , soyadi , adresi FROM liste WHERE adi = 'Bahadir '
Ö rnek1 : İ sminin ba ş harfi " B " ile ba ş layanlar ı sorgulayal ı m . A ş a ğı daki SQL komutunu inceleyiniz .
SELECT DISTINCT adi , soyadi , adresi FROM liste WHERE adi LIKE ',B%'
Ö rnek2 : İ ki ş art ı ayn ı anda sa ğ lama . Ö rne ğ imizi inceleyelim .
SELECT DISTINCT adi , soyadi , adresi , maas FROM liste WHERE ( adi = 'B%' and maas >
10000 )
İ ki ş arttan biri ger ç ekle ş mesi isteniyorsa yukardaki ö rnekte And yerine Or kullan ı lacak .
Verileri S ı ralamak
Tabloda bulunan verileri A - Z 'ye veya Z-A' ya s ı ralayabiliriz . Bunun i ç in a ş a ğı daki ö rnekleri
inceleyelim .
Ö rnek1 : SELECT DISTINCT adi , soyadi , adresi , maas FROM liste WHERE Order By adi ASC
( A - Z 'ya sıralar )
Ö rnek2 : SELECT DISTINCT adi , soyadi , adresi , maas FROM liste WHERE Order By adi
DESC ( Z - A 'ya sıralar )
Verileri Grupland ı rmak
Bir tabloda yer alan ki ş ilerin farkl ı zamanlardaki yapt ı klar ı i ş lerin miktar ı grupland ı rmak
suretiyle tek bir tabloda listelenebilir . Bunun i ç in Group BY komutunu kullanaca ğı z .
SELECT adi , soyadi , SUM ( toplam_fiyat ) Genel_toplam FROM liste Where fiyat = 'TL'
GROUP BY adi
Ö nemli Not : Ş imdiye kadar Query1 'in SQL özelliğine SQL komutları yazarak sorgulamalar
yapt ı k . Ş imdi kod penceresinde yazaca ğı m ı z program koduyla veri sorgulayaca ğı z .
Ö rnek : Parametreye ba ğ l ı olarak veri sorgulamas ı
procedure TForm1 . Button1Click ( Sender : TObject ) ; // Button1 adlı butona kodumuzu
yaz ı yoruz .
begin
Query1 . Close ;
Query1 . ParamByNAme ( ' Adi ' ). AsString := Edit1 . Text ;
Query1 . Open ;
end ;
S ü tun Sorgulama
Bunu yaparken DataSource1 'in DataSet özelliğini Query1 ; Query1' in DataBaseName
ö zelli ğ ini veri taban ı n ı z ( bizim ö rnekte liste . dbf ) ; DBGrid1 ' in DataSource özelliğinide
DataSource1 yap ı n ı z .
Ö rnek :
procedure TForm1 . Button1Click ( Sender : TObject ) ;
begin
Query1 . SQL . Clear ;
Query1 . SQL . Add ( ' Select adi , soyadi , adresi , maas From liste ' ) ;
Query1 . Open ;
end ;
Program ı m ı z ı ç al ış t ı r ı p Button1 'e tıkladığımız zaman DBGrid' de istedi ğ imiz bilgilerin listelendi ğ ini
g ö r ü r ü z .
Ekleme Sorgusu
Formumuza Button1 koyal ı m . Caption ö zelli ğ ine Ekle yazal ı m . Ekle butonuna a ş a ğı daki
kodlar ı yazal ı m . ( formumuza Query1 , DataSource1 ve DBGrid1 yerle ş tirilmi ş varsay ı yorum .
)
procedure TForm1 . EkleClick ( Sender : TObject ) ;
begin
Query1 . SQL . Add ( 'INSERT into liste ' );
Query1 . SQL . Add ( ' (ADI , SOYADI ) ' ) ;
Query1 . SQL . Add ( 'values (" Bahadir " , " Sahin " ) ' ) ;
Query1 . ExecSQL ;
end ;
Not : Program ı ç al ış t ı r ı p Ekle butonuna bast ığı m ı z zaman , kodda yazm ış oldu ğ umuz
Bahadir Sahin ' i veri tabanına ekler.
Veri G ü ncellemek
Tablomuzda bulunan verilerimizi g ü ncellemek i ç in UPDATE 'i kullanacağız. Bunun için
Formumuza Button1 koyal ı m . Caption ö zelli ğ ine G ü ncelle yazal ı m . G ü ncelle butonuna
a ş a ğı daki kodlar ı yazal ı m .
procedure TForm1 . GuncelleClick ( Sender : TObject ) ;
begin
Query1 . SQL . Clear ;
Query1 . SQL . Add ( ' UPDATE liste set maas = 10000 where ADI = ' Bahadir ' ) ;
Query1 . ExecSQL ;
end ;
Veri Silme Sorgusu
procedure TForm1 . SilClick ( Sender : TObject ) ;
begin
Query1 . SQL . Clear ;
Query1 . SQL . Add ( ' Delete from liste where ADI = ' Bahadir ' ) ;
Query1 . ExecSQL ;
end ;
Parametreye Ba ğ l ı Olarak Veri Sorgulama
procedure TForm1 . SorguClick ( Sender : TObject ) ;
begin
Query1 . SQL . Clear ;
Query1 . SQL . Add ( 'Select ADI, SOYADI from liste Where ADI =:a' ) ;
Query1 . ParamByName ( 'a' ). AsString := Edit1 . Text ;
Query1 . Open ;
end ;
Borland Delphi 'de QReport Bileşenleri ile Rapor Hazırlama
Daha ö nceki b ö l ü mlerde veri taban ı n ı nas ı l olu ş turdu ğ umuzu ve bu veri taban ı na yazm ış
oldu ğ umuz verileri nas ı l sorgulay ı p listeledi ğ imizi g ö rm üş t ü k . Ş imdi ise yapm ış oldu ğ umuz
i ş lerin meyvesini almaya geldi . Nas ı l m ı? Tabiki QReport ile ... QReport ile Printer 'dan çıktı
alabiliriz . Ş imdi QReport 'un özelliklerini inceleyelim.
· B ö l ü m ( Band ) yap ı s ı na dayanan rapor ü retici
· QReport bile ş enleri ile g ö rsel rapor tasar ı m ı
· Rapor çı kt ı s ı verme
· An ı nda ö nizleme imkan ı
· Limitsiz Memo alanlar ı
· Limitsiz Grup say ı s ı
· Karma şı k rapor tasar ı m ı
· İ ste ğ e uyarlanabilir rapor tasar ı m ı
· Yazd ı r ı labilir grafik formatlar ı
· Geli ş tirilmi ş hesap ifadeleri
· Tam yaz ı c ı kontrol ü vb . di ğ er ö zellikler ...
Ş imdi ad ı m ad ı m Rapor olu ş turmaya ba ş layal ı m . Bir rapor formu en basit a ş a ğı daki bile ş enlerden
meydana gelir .
DataSet ( TTable ) eleman ı
QuickReport ( TTable ile ba ğ lant ı l ı )
QuickReport ü zerine al ı nan QRBand bile ş eni
TQuickRep eleman ı n ı n Bands ö zelli ğ i alt ı ndaki HasDetail ö zelli ğ inin True yap ı lmas ı
Detail b ö l ü m ü ü zerine yaz ı labilir TQRDBText eleman ı
Bunlar ı öğ rendikten sonra raporumuzu haz ı rlamaya devam edelim . İ lk ö nce Formumuza
Data Access k ı sm ı ndan TTable kontrol ü n ü yerle ş tirelim . Table1 'in Object
Inspector 'ündeki DatabaseName özelliğini oluşturduğumuz aliası ( Ben liste.dbf oluşturdum.
Sizde olu ş turdu ğ unuz veri taban ı n ı se ç in .) se ç elim . TableName 'de veritabanının ismini
se ç elim . Table1 'in Active özelliğini True yapalım. Sonra QReport kısmından
QuickRep1 eleman ı n yerle ş tirelim ve DataSet ö zelli ğ ini Table1 yapal ı m . Daha sonra Bands
ö zelli ğ ine t ı klay ı p HasDetail ö zelli ğ ini True yapal ı m . Bu i ş lem ile form ü zerine veri alanlar ı n ı n
yer alaca ğı b ö l ü m ü eklemi ş olduk . Ş imdi bir ö rnek yapal ı m .
Ö rnek : Yukar ı daki i ş lemleri ger ç ekle ş tirdikten sonra QReport k ı sm ı ndan 5 adet QRDBText
kontrol ü al ı p Details k ı sm ı na yerle ş tirelim ve herbir QRDBText 'in Dataset özelliğini Table1
ve DataField ö zelli ğ inide liste . dbf 'de bulunan sütun alanlarından birini seçelim ( Mesela
ADI , SOYADI , ADRESI ). Basit bir rapor yapm ış olduk . Ş imdi tasar ı m zaman ı ndaki raporu
g ö rebilmek i ç in QuickRep1 'in üzerindeyken, Mouse' ı n sa ğ tu ş una t ı klayal ı m . Kar şı m ı za bir
men ü çı kar . Ş imdi bu men ü deki ö zellikleri inceleyelim .
Report Setting : Tasar ı m zaman ı rapor ile ilgili ayarlar ı n yer ald ığı pencereye ula şı l ı r .
Zoom in : Tasar ı m zaman ı nda rapor ü zerindeki bile ş enler daha b ü y ü k g ö sterilir .
Zoom Out : Tasar ı m zaman ı nda rapor ü zerindeki bile ş enler daha k üçü k g ö sterilir .
Rotate Band View : Rapor ü zerinde yer alan bile ş enlerin yerleri de ğ i ş tirilir .
Hide Bands : Bu ö zellikle bile ş enler gizlenir .
Reset : Gizlenen b ö l ü mleri tekrar g ö sterir .
Preview : Bu ö zellik ; Raporumuzun ekran g ö r ü nt ü s ü n ü çı kar ı r .
Raporla İ lgili Ayarlar
Tasar ı m zaman ı nda raporla ilgili ayarlar ı n yap ı labilmesi i ç in QuickRep1 'e sağ tıklanır. Açılan
men ü de Report Setting se ç ene ğ i se ç ilir . A çı lan men ü de ;
Paper Size : Ka ğı d ı n tipi belirlenir .
Length : Sayfa uzunlu ğ u belirlenir .
Width : Sayfa geni ş li ğ i belirlenir .
Margins : Kenarlarda b ı rak ı lacak bo ş luk miktar ı belirlenir .
Column Space : S ü tun geni ş li ğ i belirlenir .
Number of Column : S ü tun say ı s ı belirlenir .
Other : Bu k ı s ı mda raporda kullan ı lacak font ad ı, b ü y ü kl üğü ve ö l çü birimi ayarlan ı r .
Page Frame : Bu b ö l ü mde ise rapor ö nizleme modunda iken g ö z ü kecek ç er ç eveler , ç er ç evenin
rengi , kal ı nl ığı ayarlan ı r .
Bands : Rapora eklenecek b ö l ü mler ( Band ) se ç ilir .
Page Header : Rapora Sayfa Ba ş l ığı verilir .
Title : Ba ş l ı k girilir .
Column Header : S ü tun ba ş l ı klar ı girilir .
Detail Band : Veri alanlar ı n ı n yer ald ığı b ö l ü md ü r .
Page Footer : Sayfan ı n alt ı nda yer alan sayfa alt bilgilerini ekler .
Summary : Raporla ilgili ek a çı klamalar ı ekler .
Ç al ış ma An ı nda Rapor Ö nizleme
Bunun i ç in ş u i ş lemleri yap ı n ı z . İ lk ö nce Formumuza bir Button ekleyin ve bu button1 'in
Caption ö zelli ğ ine Raporla yaz ı n ı z . Daha sonra butonun OnClick k ı sm ı na a ş a ğı daki kodu
yaz ı n ı z .
Procedure TForm1 . RaporlaClick ( Sender : TObject ) ;
begin
QuickRep1 . Preview ;
end ;
Program ı ç al ış t ı r ı p Raporla butonuna bast ığı m ı z zaman , raporumuzun ekran g ö r ü nt ü s ü
kar şı m ı za gelir .
Not : Kay ı tlar ı direk yaz ı c ı ya g ö ndermek istiyorsak , Butonun OnClick olay ı na ş u kodu yazaca ğı z .
QuickRep1 . Print ;
Wizard Kullanarak Rapor Haz ı rlama
· File / New Aplication 'u seçin.
· File / New men ü s ü nden Business k ı sm ı na ge ç iniz . Buradan QuickReport Wizard
se ç ene ğ ini se ç iniz . Sonra Ok d üğ mesine bas ı n ı z .
· Çı kan pencerede Start Wizard d üğ mesiyle bir sonraki ad ı ma ge ç elim .
· Alias or Directory kutusunda ba ğ lant ı kuraca ğı m ı z veritaban ı n ı n bulundu ğ u dizini
se ç iyoruz . Table Name k ı sm ı nada veri taban ı m ı z ı n ismini se ç iyoruz .
· Tablo se ç ildikten sonra ; tablomuzda yer alan s ü tunlar g ö r ü lecektir . Raporda bulunmas ı n ı
istedi ğ imiz alanlar ı belirleyip > veya hepsini se ç ersek >> tu ş uyla sa ğ taraftaki
listeye alal ı m ve bu i ş lemi bitirdikten sonra Finish d üğ mesine basal ı m . B ö ylece
Wizard kullanarak otomatik olarak raporumuzu olu ş turmu ş bulunuyoruz .
Veri S ü zmek ve S ı ralamak
QuickReport ; verileri s ı ralayacak herhangi bir ö zelli ğ e sahip de ğ ildir . Veriler girildikleri s ı rada
bas ı l ı rlar . Veri taban ı i ç indeki veri alanlar ı n ı n index olarak tan ı mlanmas ı gerekir . Bu
i ş lemden sonra TTable eleman ı n ı n IndexName ö zelli ğ i ile belirtilmesi gerekir . TQuery
eleman ı ylada istenilen ş ekilde verileri s ü zmek m ü mk ü nd ü r . Veri s ü zme birka ç ş ekilde yap ı l ı r .
TTable . Filter ö zelli ğ i bir s ü zme ko ş ulu ekler . Bu s ı rada TTable . Filtered ö zelli ğ i True
olmas ı gerekir . Di ğ er yol SQL kullan ı larak istenilen kay ı tlar ı elde etmektir . Bir di ğ er se ç enek
ise Detail band ı n ı n PrintEvent olay ı n ı kullanmakt ı r .
Sayfa B ü y ü kl üğü ve Kenar Bo ş luklar ı n ı Ayarlama
Bunun i ç in QuickRep1 eleman ı n ı n Page ö zelli ğ ine t ı klanarak a çı lan alt ö zellikler arac ı l ığı yla
rapor tasar ı m ı nda kullan ı lacak olan sayfan ı n b ü y ü kl üğü ve kenar bo ş luklar ı kolay bir ş ekilde
ayarlan ı r .
Not : QuickRep1 'in içinde varsayılan yazı tipleri seçilebilir. Bunun için Font özelliğine tıklanması
gerekir . Burada font ad ı, tipi , rengi fontun alt ı veya ü st ü ç izili olma durumu
ayarlanabilir .
Rapor Ba ş l ığı
Rapor tan ı mlama QuickReport 'un Description özelliği ile yapılır. Bu seçeneği tıklayalım ve
a çı lan pencereye raporla ilgili bilgileri girelim . Bir rapor ba ş l ığı TQRSysData eleman ı arac ı l ığı yla
yazd ı r ı labilir . Ba ş l ı k a ş a ğı daki kodla olu ş turulabilir .
Ö rnek : procedure TForm1 . Button1Click ( Sender : TObject ) ;
begin
with QuickRep1 do
begin
Report Title := ' Personel Bilgisi Raporu ' ;
Bands . HasTitle := True ;
with TQRSysData ( Bands . TitleBand . AddPrintable ( TQRSysData ) ) do
begin
Data := qrsReportTitle ;
AlignToBand := true ;
Aligment := taCenter ;
end ;
Preview ;
end ;
end ;
Bir Rapora B ö l ü m Eklemek
Bir rapora b ö l ü m eklemek i ç in Object Inspector penceresinden TQuickRep eleman ı na ait
Bands ö zelli ğ ine t ı klamak ve çı kan alt b ö l ü mdeki ö zelliklerin de ğ erini true yapmakt ı r .
Quick Report 'ta Kullanılan Operatörler
Operat ö r A çı klama
+ Toplama
- Çı karma
* Ç arpma
/ B ö lme
( ) Parantez
And Mant ı ksal And
Or Mant ı ksal Or
Not Mant ı ksal Not
= E ş it
< K üçü k
> B ü y ü k
<= K üçü k e ş it
>= B ü y ü k e ş it
< > E ş it de ğ il
QuickReport Fonksiyonlar ı
Date : Mevcut tarihi string olarak geri g ö nderir . Rapor ü zerine QRExpr eleman ı al ı narak
Expression ö zelli ğ ine Date verilerek kullan ı l ı r .
Time : Mevcut saati stringe ç evirir . Rapor ü zerine QRExpr eleman ı al ı narak Expression
ö zelli ğ ine Time verilerek kullan ı l ı r .
Str ( say ı ): Say ı sal bir ifadeyi stringe ç evirir .
Copy ( str , s , l ): Bir ifadenin i ç inde bulunan belli bir b ö l ü m ü geri g ö nderir .
Rapora Sayfa Numaras ı ve Tarih Eklemek
Raporumuza sayfa numaras ı ve tarih eklemek i ç in ; rapor ü zerine QRB eleman ı alarak
BandType ö zelli ğ ini rbPageFooter yapal ı m . Daha sonra QRSYSData kontrol ü nden iki tane
al ı p birincisinin Data ö zelli ğ ini qrsDate ve Text ö zelli ğ ine " Bas ı m Tarihi ", ikincisinin Data
ö zelli ğ ini qrsPageNumber ve Text ö zelli ğ ini de " Sayfa : " yapal ı m . Raporu Preview 'e tıklayarak
ö nizlemeye al ı rsak sayfan ı n sonunda Bas ı m Tarihi ve Sayfa Numaras ı n ı n yaz ı lm ış oldu ğ unu
g ö r ü r ü z .
Delphi ile MS Access Database 'ine Bağlantı
Delphi 'den MS Access Databaseine ulaşabilmek için sırasıyla yapılması gerekenler aşağıdaki
gibidir :
1. Windows Control Panel 'i açın.
2. ODBC simgesini ç ift t ı klay ı n .
3. User DSN tab ı na gelin ve Add butonuna bas ı n .
4. Driver olarak " Microsoft Access Driver (*.mdb)" yi seçin ve Finish butonuna basın.
5. Data Source Name'i olarak kullanmak istediğiniz bir isim verin. Description kısmına
isterseniz database'inizle ilgili bir açıklama yazabilirsiniz.
6. Daha sonra Select butonuna basarak database isminizi verin.
7. Advanced butonuna basarak kullanıcı adı ve şifresi tanımlayabilirsiniz. ( Zorunlu değil )
8. OK butonuna basıp ODBC ekranını kapatın.
9. Şimdi programınıza bir TDatabase objesi ekleyin.
10. AliasName olarak ODBC ayarlarında verdiğiniz, (5) Data Source Name'i seçin.
11. Database Name olarak istediğiniz bir isim yazın.
12. Eğer
için LoginPrompt seçeneğini false yapın.
Not: Eğer
durumunda database'e ulaşamazsınız.
13. Programınıza bit TTable ekleyin.
14. Database Name kısmına TDatabase bileşeninde, Database Name kısmına 11. adımda
verdiğiniz ismi seçin.
15. Programınıza bit TDataSource ekleyin.
16. DataSet değeri olarak 13. adımda eklediğiniz TTable adını verin.
Artık MS Access Database'ine bağlı bir table'a sahipsiniz.
Delphi - .....................................
Muhtelif Kodlar 1
procedure TForm1 . Button1Click ( Sender : TObject );
begin
Form2 . ShowModal ;
end ;
procedure TForm2 . CancelButtonClick ( Sender : TObject );
begin
Form2 . Close ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
Form1 . Color := clAqua ;
end ;
procedure TForm1 . AddBtnClick ( Sender : TObject );
begin
Listbox1 . Items . Add ( Edit1 . Text ); {add this line of code}
end ;
procedure TForm1 . ClearBtnClick ( Sender : TObject );
begin
ListBox1 . Items . Clear ; {add this line of code}
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
AboutBox . Caption := 'About ' + Application . Title ; { use the application’s name }
AboutBox . ShowModal ; { then open the dialog box }
end
procedure TMain1 . Button1Click ( Sender : TObject );
begin
if Sender = Button1 then {this is the first line you add}
AboutBox . Caption := 'About ' + Application . Title {remove the existing semicolon}
else AboutBox . Caption := '' ; {this is the second line you add}
AboutBox . ShowModal ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
MessageDlg ( 'Save changes?' , mtConfirmation , mbYesNoCancel , 0 );
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
Label1 . Caption := InputBox ( 'Password Entry Form' , 'Enter Password' , '' )
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
PasswordDlg . ShowModal ;
end ;
procedure TMainForm . Button1Click ( Sender : TObject );
begin
AboutBox . Show ; {This is the line you need to write}
end ;
procedure TMainForm . Button1Click ( Sender : TObject );
begin
AboutBox . ShowModal ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
Button2 . Enabled := False ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
Memo1 . Lines . Add ( Edit1 . Text );
Edit1 . Clear ;
end ;
procedure TForm1 . SpeedButton1Click ( Sender : TObject );
begin
Form2 . Show ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
Edit1 . Color := clRed ;
end ;
procedure TForm1 . ColorGrid1Click ( Sender : TObject );
begin
Edit1 . Color := ColorGrid1 . ForegroundColor ;
end ;
procedure TForm1 . AddButtonClick ( Sender : TObject );
var
X , Y , Sum : Integer ;
begin
X := 100 ;
Y := 10 ;
Sum := X + Y ;
Edit1 . Text := IntToStr ( Sum );
end ;
procedure TForm1 . AddButtonClick ( Sender : TObject );
var
X , Y : Integer ;
begin
X := 100 ;
Y := 10 ;
Edit1 . Text := IntToStr ( X + Y );
end ;
procedure TForm1 . CutClick ( Sender : TObject );
begin
Memo1 . CutToClipboard ;
end ;
procedure TForm1 . CopyClick ( Sender : TObject );
begin
Memo1 . CopyToClipboard ;
end ;
procedure TForm1 . PasteClick ( Sender : TObject );
begin
Memo1 . PasteFromClipboard ;
end ;
procedure TForm1 . ClearAllClick ( Sender : TObject );
begin
Memo1 . Clear ;
end ;
procedure TForm1 . AddButtonClick ( Sender : TObject );
var
X , Y , Sum : Integer ;
begin
X := 100 ;
Y := 10 ;
Sum := X + Y ;
Edit1 . Text := IntToStr ( Sum );
end ;
procedure TForm1 . ChangeColorClick ( Sender : TObject );
begin
if ColorDialog1 . Execute then { if user clicks OK button }
Form1 . Color := ColorDialog1 . Color
else
Form1 . Color := clRed ;
end ;
procedure TForm1 . OKClick ( Sender : TObject );
begin
if Edit1 . Text = 'Saturday' then
Label2 . Caption := 'Why are you working today?' ;
end ;
procedure TForm1 . OKClick ( Sender : TObject );
begin
if Edit1 . Text = 'Saturday' then
Label2 . Caption := 'Why are you working today?'
else
Label2 . Caption := '' ;
end ;
procedure TForm1 . OKClick ( Sender : TObject );
begin
if Edit1 . Text = 'Saturday' then
begin
Label2 . Caption := 'Why are you working today?' ;
Form1 . Color := clYellow ;
end
else
Label2 . Caption := '' ;
end ;
procedure TForm1 . OKClick ( Sender : TObject );
begin
if Edit1 . Text = 'Saturday' then
Label2 . Caption := 'Why are you working today?'
else
if Edit1 . Text = 'Sunday' then
Label2 . Caption := 'You should be resting'
else
if Edit1 . Text = 'Monday' then
Label2 . Caption := 'Welcome to a new work week!'
else
Label2 . Caption := '' ;
end ;
procedure TForm1 . OKClick ( Sender : TObject );
var
Number : Integer ;
begin
Number := StrToInt ( Edit1 . Text );
case Number of
1 , 3 , 5 , 7 , 9 : Label2 . Caption := 'Odd digit' ;
0 , 2 , 4 , 6 , 8 : Label2 . Caption := 'Even digit' ;
10 .. 100 : Label2 . Caption := 'Between 10 and 100' ;
else
Label2 . Caption := 'Greater than 100 or negative' ;
end ;
end ;
procedure TForm1 . RepeatButtonClick ( Sender : TObject );
var
I : Integer ;
begin
I := 0 ;
repeat
I := I + 1 ;
Writeln ( I );
until I = 10 ;
end ;
procedure TForm1 . WhileButtonClick ( Sender : TObject );
var
J : Integer ;
begin
J := 0 ;
while J < 10 do
begin
J := J + 1 ;
Writeln ( J : 50 );
end ;
end ;
procedure TForm1 . CountButtonClick ( Sender : TObject );
var
Col : Integer ;
begin
for Col := 1 to 5 do
StringGrid1 . Cells [ Col , 1 ] := IntToStr ( Col );
end ;
procedure TForm1 . CountButtonClick ( Sender : TObject );
var
Col : Integer ;
begin
for Col := 5 downto 1 do
StringGrid1 . Cells [ Col , 1 ] := IntToStr ( Col );
end ;
procedure TForm1 . ShowCoordinatesButtonClick ( Sender : TObject );
var
Col , Row : Integer ;
begin
for Col := 1 to 5 do
StringGrid1 . Cells [ Col , 0 ] := 'Col ' + IntToStr ( Col );
for Row := 1 to 5 do
StringGrid1 . Cells [ 0 , Row ] := 'Row ' + IntToStr ( Row );
for Col := 1 to 5 do
for Row := 1 to 5 do
StringGrid1 . Cells [ Col , Row ] :=
'Col ' + IntToStr ( Col ) + ', ' + 'Row ' + IntToStr ( Row );
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin { The block starts here with the statement part }
Edit1 . Text := 'Welcome to Delphi ' ;
end ;
var { The block begins here with the start of the declaration part }
Name : string ;
begin { The statement part of the block begins }
Name := Edit1 . Text ;
Edit2 . Text := 'Welcome to Delphi , ' + Name ;
end ;
procedure TForm1 . MultiplyClick ( Sender : TObject ); { Multiplies two numbers together }
var
FirstNumber , SecondNumber : Integer ;
begin
FirstNumber := StrToInt ( Edit1 . Text );
SecondNumber := StrToInt ( Edit2 . Text );
Edit3 . Text := IntToStr ( FirstNumber * SecondNumber ); { Displays answer in Edit3 }
end ;
procedure TForm1 . DivideClick ( Sender : TObject );
begin
FirstNumber := StrToInt ( Edit1 . Text );
SecondNumber := StrToInt ( Edit2 . Text );
Edit3 . Text := IntToStr ( FirstNumber div SecondNumber );
end ;
procedure TForm1 . DivideClick ( Sender : TObject );
var
FirstNumber , SecondNumber : Integer ;
begin
FirstNumber := StrToInt ( Edit1 . Text );
SecondNumber := StrToInt ( Edit2 . Text );
Edit3 . Text := IntToStr ( FirstNumber div SecondNumber );
end ;
implementation
{$R *.DFM}
var
FirstNumber , SecondNumber : Integer ; { Variables global to the event handlers }
procedure TForm1 . MultiplyClick ( Sender : TObject ); { Multiplies two numbers together }
begin
FirstNumber := StrToInt ( Edit1 . Text );
SecondNumber := StrToInt ( Edit2 . Text );
Edit3 . Text := IntToStr ( FirstNumber * SecondNumber ); { Displays result in Edit3 }
end ;
procedure TForm1 . DivideClick ( Sender : TObject ); { Divides first number by the second }
begin
FirstNumber := StrToInt ( Edit1 . Text );
SecondNumber := StrToInt ( Edit2 . Text );
Edit3 . Text := IntToStr ( FirstNumber div SecondNumber ); { Displays result in Edit3 }
end ;
procedure TForm1 . DivideClick ( Sender : TObject );
var
FirstNumber , SecondNumber , Count : Integer ;
begin
Count := 0 ;
FirstNumber := StrToInt ( Edit1 . Text );
SecondNumber := StrToInt ( Edit2 . Text );
Edit3 . Text := IntToStr ( FirstNumber div SecondNumber );
Count := Count + 1 ;
Counter . Text := IntToStr ( Counter );
end ;
implementation
{$R *.DFM}
var
Count : Integer ;
procedure TForm1 . MultiplyClick ( Sender : TObject );
var
FirstNumber , SecondNumber : Integer ;
begin
FirstNumber := StrToInt ( Edit1 . Text );
SecondNumber := StrToInt ( Edit2 . Text );
Edit3 . Text := IntToStr ( FirstNumber * SecondNumber );
Count := Count + 1 ;
Counter . Text := IntToStr ( Count );
end ;
procedure TForm1 . DivideClick ( Sender : TObject );
var
FirstNumber , SecondNumber : Integer ;
begin
FirstNumber := StrToInt ( Edit1 . Text );
SecondNumber := StrToInt ( Edit2 . Text );
Edit3 . Text := IntToStr ( FirstNumber div SecondNumber );
Count := Count + 1 ;
Counter . Text := IntToStr ( Count );
end ;
initialization
Count := 0 ;
end
function NoValue ( AnEditBox : TEdit ): Boolean ;
begin
if AnEditBox . Text = '' then
begin
AnEditBox . Color := clRed ;
AnEditBox . Text := 'Enter a value' ;
Result := True ;
end
else
begin
AnEditBox . Color := clWindow ;
Result := False ;
end ;
end ;
procedure TForm1 . MultiplyClick ( Sender : TObject );
var
FirstNumber , SecondNumber : Integer ;
begin
if NoValue ( Edit1 ) or NoValue ( Edit2 ) then { This line calls NoValue twice }
Exit ; { If an edit box is empty, quit this event handler }
FirstNumber := StrToInt ( Edit1 . Text );
SecondNumber := StrToInt ( Edit2 . Text );
Edit3 . Text := IntToStr ( FirstNumber * SecondNumber );
Count := Count + 1 ;
Counter . Text := IntToStr ( Count );
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
Number : Integer ;
begin
Number := StrToInt ( Edit1 . Text );
Calculate ( Number );
Edit2 . Text := IntToStr ( Number );
end ;
implementation
{$R *.DFM}
type
TCourse = ( Nothing , History , Literature , Biology , Psychology );
var
SelectedCourse : TCourse ;
procedure TForm1 . HistoryButtonClick ( Sender : TObject );
begin
SelectedCourse := History ;
end ;
procedure TForm1 . LiteratureButtonClick ( Sender : TObject );
begin
SelectedCourse := Literature ;
end ;
procedure TForm1 . BiologyButtonClick ( Sender : TObject );
begin
SelectedCourse := Biology ;
end ;
procedure TForm1 . PsychologyButtonClick ( Sender : TObject );
begin
SelectedCourse := Psychology ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
case SelectedCourse of
History : Label1 . Caption := 'You are taking history' ;
Literature : Label1 . Caption := 'You are taking literature' ;
Biology : Label1 . Caption := 'You are taking biology' ;
Psychology : Label1 . Caption := 'You are taking psychology' ;
else
Label1 . Caption := 'You are taking nothing' ;
end ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
{$R+}
type
TValidEntry = 1 .. 100 ;
var
Entry : TValidEntry ;
begin
Entry := StrToInt ( Edit1 . Text );
Label2 . Caption := 'Excellent!' ;
end ;
procedure TForm1 . FindLengthClick ( Sender : TObject );
type
TEditString = string ;
var
UserString : TEditString ;
begin
UserString := Edit1 . Text ;
Label2 . Caption := 'This string is ' + IntToStr ( Length ( UserString )) +
' characters in length' ;
end ;
procedure TForm1 . FindLengthClick ( Sender : TObject );
begin
Label2 . Caption := 'This string is ' + IntToStr ( Length ( Edit1 . Text )) +
' characters in length' ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
type
TVowels = set of Char ;
var
Vowels : TVowels ;
begin
Vowels := [ 'A' , 'E' , 'I' , 'O' , 'U' ];
if Edit1 . Text [ 1 ] in Vowels then
Label2 . Caption := 'You are clever'
else
Label2 . Caption := 'Please try again' ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
Form1 . Color := clGreen ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
Color := clFuchsia ;
Edit1 . Color := clLime ;
end ;
begin
ListBox1 . Clear ;
ListBox1 . MultiSelect := True ;
ListBox1 . Items . Add ( 'One' );
ListBox1 . Items . Add ( 'Two' );
ListBox1 . Items . Add ( 'Three' );
ListBox1 . Sorted := True ;
ListBox1 . Font . Style := [ fsBold ];
ListBox1 . Font . Color := clPurple ;
ListBox1 . Font . Name := 'Times New Roman' ;
ListBox1 . ScaleBy ( 125 , 100 );
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
with ListBox1 do
begin
Clear ;
MultiSelect := True ;
Items . Add ( 'One' );
Items . Add ( 'Two' );
Items . Add ( 'Three' );
Sorted := True ;
Font . Style := [ fsBold ];
Font . Color := clPurple ;
Font . Name := 'Times New Roman' ;
ScaleBy ( 125 , 100 );
end ;
end ;
procedure TForm1 . Button1Click ( Sender : TComponent );
var
APointer : Pointer ;
AnInteger , ADividend : Integer ;
begin
ADividend := 0 ;
GetMem ( APointer , 1024 ); { allocate 1K of memory }
AnInteger := 10 div ADividend ; { this generates an error }
FreeMem ( APointer , 1024 ); { it never gets here }
end ;
procedure TForm1 . Button1Click ( Sender : TComponent );
var
APointer : Pointer ;
AnInteger , ADividend : Integer ;
begin
ADividend := 0 ;
GetMem ( APointer , 1024 ); { allocate 1K of memory }
try
AnInteger := 10 div ADividend ; { this generates an error }
finally
FreeMem ( APointer , 1024 ); { execution resumes here, despite the error }
end ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
ListBox1 . Items . Add ( 'a string' ); { add a string to list box }
ListBox1 . Items . Add ( 'another string' ); { add another string... }
ListBox1 . Items . Add ( 'still another string' ); { ...and a third string }
try
Caption := ListBox1 . Items [ 3 ]; { set form caption to fourth string in list box }
except
on EListError do
MessageDlg ( 'List box contains fewer than four strings' , mtWarning , [ mbOK ], 0 );
end ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
I : Integer ;
begin
for I := 1 to 10 do { loop ten times }
begin
ListBox1 . Items . Add ( IntToStr ( I )); { add a numeral to the list }
if I = 7 then Abort ; { abort after the seventh one }
end ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
Index : Integer ;
begin
for Index := 0 to ListBox1 . Items . Count - 1 do
ListBox1 . Items [ Index ] := UpperCase ( ListBox1 . Items [ Index ]);
end ;
procedure TForm1 . FormCreate ( Sender : TObject );
var
FileName : string ; { storage for file name }
begin
FileName := 'C:AUTOEXEC.BAT' ; { set the file name }
with Memo1 do
begin
LoadFromFile ( FileName ); { load from file }
SaveToFile ( ChangeFileExt ( FileName , 'BAK' )); { save into backup file }
end ;
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
var
TempList : TStrings ; { declare the list }
begin
TempList := TStringList . Create ; { construct the list object }
try
{ use the string list }
finally
TempList . Free ; { destroy the list object }
end ;
end ;
procedure TForm1 . FormCreate ( Sender : TObject );
begin
ClickList := TStringList . Create ; { construct the list }
end ;
procedure TForm1 . FormDestroy ( Sender : TObject );
begin
ClickList . SaveToFile ( ChangeFileExt ( Application . ExeName , '.LOG' )); { save the list }
ClickList . Free ; { destroy the list object }
end ;
procedure TForm1 . FormMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
ClickList . Add ( Format ( 'Click at (%d, %d)' , [ X , Y ])); { add a string to the list }
end ;
procedure TFrameForm . NewChild ( Sender : TObject );
var
EditForm : TEditForm ; {declare the child form as a variable}
begin
EditForm := TEditForm . Create ( Self ); {create the new child window}
end ;
procedure TEditForm . New1Click ( Sender : TObject );
begin
FrameForm . NewChild ( Sender );
end ;
procedure TFrameForm . Tile1Click ( Sender : TObject );
begin
Tile ; {this is the only code you write}
end ;
procedure TFrameForm . Cascade1Click ( Sender : TObject );
begin
Cascade ; {this is the only code you write}
end ;
procedure TFrameForm . ArrangeIcons1Click ( Sender : TObject );
begin
ArrangeIcons ; {this is the only code you write}
end ;
procedure TEditForm . AlignClick ( Sender : TObject );
begin
Left1 . Checked := False ;
Right1 . Checked := False ;
Center1 . Checked := False ;
with Sender as TMenuItem do Checked := True ;
with Memo1 do
if Left1 . Checked then
Alignment := taLeftJustify
else if Right1 . Checked then
Alignment := taRightJustify
else if Center1 . Checked then
Alignment := taCenter ;
end ;
procedure TEditForm . SetWordWrap ( Sender : TObject );
begin
with Memo1 do
begin
WordWrap := not WordWrap ;
if WordWrap then
ScrollBars := ssVertical else
ScrollBars := ssBoth ;
WordWrap1 . Checked := WordWrap ;
end ;
end ;
procedure TEditForm . SelectAll ( Sender : TObject );
begin
Memo1 . SelectAll ;
end ;
procedure TEditForm . CutToClipboard ( Sender : TObject );
begin
Memo1 . CutToClipboard ;
end ;
procedure TEditForm . CopyToClipboard ( Sender : TObject );
begin
Memo1 . CopyToClipboard ;
end ;
procedure TEditForm . PasteFromClipboard ( Sender : TObject );
begin
Memo1 . PasteFromClipboard ;
end ;
procedure TEditForm . Delete ( Sender : TObject );
begin
Memo1 . ClearSelection ;
end ;
procedure TEditForm . UpdateMenus ;
var
HasSelection : Boolean ; {declare a variable that stores the results of the Boolean}
begin
Paste1 . Enabled := Clipboard . HasFormat ( CF_TEXT ); {enable or disable the Paste menu item}
HasSelection := Memo1 . SelLength <> 0 ; {assign the value of the Boolean variable based on
whether any text is selected in the Memo}
Cut1 . Enabled := HasSelection ; {enable the menu items if HasSelection evaluates to True}
Copy1 . Enabled := HasSelection ;
Delete1 . Enabled := HasSelection ;
end ;
procedure TEditForm . SetEditItems ( Sender : TObject );
begin
UpdateMenus ;
end ;
procedure TEditForm . UpdateMenus ;
var
HasSelection : Boolean ;
begin
Paste1 . Enabled := Clipboard . HasFormat ( CF_TEXT );
Paste2 . Enabled := Clipboard . HasFormat ( CF_TEXT ); {Add this line}
HasSelection := Memo1 . SelLength <> 0 ;
Cut1 . Enabled := HasSelection ;
Cut2 . Enabled := HasSelection ; {Add this line}
Copy1 . Enabled := HasSelection ;
Copy2 . Enabled := HasSelection ; {Add this line}
Delete1 . Enabled := HasSelection ;
end ;
procedure TEditForm . SetPopUpItems ( Sender : TObject );
begin
UpdateMenus ;
end ;
procedure TEditForm . Open1Click ( Sender : TObject );
begin
FrameForm . OpenChild ( Sender );
end ;
procedure TFrameForm . OpenChild ( Sender : TObject );
var
EditForm : TEditForm ;
begin
if OpenFileDialog . Execute then
begin
EditForm := TEditForm . Create ( Self );
EditForm . Open ( OpenFileDialog . Filename ); {Calls the Open method of EditForm}
EditForm . Visible := True ;
end ;
end ;
procedure TEditForm . Open ( const AFilename : string );
begin
Filename := AFilename ; {assigns the parameter passed from FrameForm.OpenChild to the
form variable}
Memo1 . Lines . LoadFromFile ( FileName ); {loads the file specified in the form variable}
Memo1 . SelStart := 0 ;
Caption := ExtractFileName ( FileName ); {displays the filename in the form caption}
Memo1 . Modified := False ;
end ;
procedure TEditForm . SaveAs1Click ( Sender : TObject );
begin
SaveFileDialog . Filename := Filename ; {display current value of Filename, if any}
if SaveFileDialog . Execute then
begin
Filename := SaveFileDialog . Filename ;
Caption := ExtractFileName ( Filename );
Save1Click ( Sender );
end ;
end ;
procedure TEditForm . Save1Click ( Sender : TObject );
procedure CreateBackup ( const Filename : string );
var
BackupFilename : string ;
begin
BackupFilename := ChangeFileExt ( Filename , BackupExt );
DeleteFile ( BackupFilename );
RenameFile ( Filename , BackupFilename );
end ;
begin
if Filename = '' then
SaveAs1Click ( Sender )
else
begin
CreateBackup ( Filename );
Memo1 . Lines . SaveToFile ( Filename );
Memo1 . Modified := False ;
end ;
end ;
procedure TEditForm . SetFont ( Sender : TObject );
begin
FontDialog1 . Font := Memo1 . Font ;
if FontDialog1 . Execute then
Memo1 . Font := FontDialog1 . Font ;
end ;
procedure TEditForm . PrintSetUp1Click ( Sender : TObject );
begin
PrinterSetupDialog1 . Execute ;
end ;
procedure TEditForm . Print1Click ( Sender : TObject );
var
Line : Integer ; {declare an integer variable for the number of lines of text}
PrintText : System . Text ; {declare PrintText as text file defined in System unit}
begin
if PrintDialog1 . Execute then
begin
AssignPrn ( PrintText ); {assign the global variable PrintText to the printer}
Rewrite ( PrintText ); {create and open the output file}
Printer . Canvas . Font := Memo1 . Font ; {assign the current Font setting for Memo1 to the
Printer object's canvas}
for Line := 0 to Memo1 . Lines . Count - 1 do
Writeln ( PrintText , Memo1 . Lines [ Line ]); {write the contents of the Memo to the
printer object}
CloseFile ( PrintText );
end ;
end ;
procedure TEditForm . Close1Click ( Sender : TObject );
begin
Close ;
end ;
procedure TEditForm . FormClose ( Sender : TObject ; var Action : TCloseAction );
begin
Action := caFree ;
end ;
procedure TEditForm . FormCloseQuery ( Sender : TObject ; var CanClose : Boolean );
var
DialogValue : Integer ; {declare an integer variable to store the user's response
to the message dialog}
FName : string ; {declare a string variable to store the value of
the file name when saving}
begin
if Memo1 . Modified then
begin
FName := Caption ; {save the value of the Caption property to the FName variable}
if Length ( FName ) = 0 then
FName := 'Untitled' ; {if there is no filename, use 'Untitled'}
DialogValue := MessageDlg ( Format ( SWarningText , [ FName ]), mtConfirmation ,
[ mbYes , mbNo , mbCancel ], 0 ); {produce the message dialog box}
case DialogValue of
id_Yes : Save1Click ( Self ); {Self parameter saves the instance of EditForm open at
the time the user chooses Yes in the dialog} }
id_Cancel : CanClose := False ; {if the user chooses Cancel, exit the dialog and
don’t close the form}
end ;
end ;
end ;
procedure TEditForm . Exit1Click ( Sender : TObject );
begin
FrameForm . Exit1Click ( Sender );
end ;
procedure TFrameForm . Exit1Click ( Sender : TObject );
begin
Close ;
end ;
procedure TForm1 . CheckBox1Click ( Sender : TObject );
begin
CheckBox1 . Font . Color := Canvas . Pixels [ 10 , 10 ];
end ;
procedure TForm1 . Button1Click ( Sender : TObject );
begin
Canvas . Pixels [ Random ( ClientWidth ), Random ( ClientHeight )] := clRed ;
end ;
procedure TForm1 . FormPaint ( Sender : TObject );
begin
with Canvas do
begin
MoveTo ( 0 , 0 );
LineTo ( ClientWidth , ClientHeight );
MoveTo ( 0 , ClientHeight );
LineTo ( ClientWidth , 0 );
end ;
end ;
procedure TForm1 . FormPaint ( Sender : TObject );
begin
with Canvas do
PolyLine ([ Point ( 0 , 0 ), Point ( 50 , 0 ), Point ( 75 , 50 ), Point ( 25 , 50 ), Point ( 0 , 0 )]);
end ;
procedure TForm1 . FormPaint ( Sender : TObject );
begin
Canvas . Rectangle ( 0 , 0 , ClientWidth div 2 , ClientHeight div 2 );
Canvas . Ellipse ( 0 , 0 , ClientWidth div 2 , ClientHeight div 2 );
end ;
procedure TForm1 . FormPaint ( Sender : TObject );
begin
Canvas . RoundRect ( 0 , 0 , ClientWidth div 2 , ClientHeight div 2 , 10 , 10 );
end ;
procedure TForm1 . FormPaint ( Sender : TObject );
begin
Canvas . Polygon ([ Point ( 0 , 0 ), Point ( 0 , ClientHeight ),
Point ( ClientWidth , ClientHeight )]);
end ;
procedure TForm1 . FormMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
end ;
procedure TForm1 . FormMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
Canvas . TextOut ( X , Y , 'Here!' ); { write text at (X, Y) }
end ;
procedure TForm1 . FormMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
Canvas . MoveTo ( X , Y ); { set pen position }
end ;
procedure TForm1 . FormMouseUp ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
Canvas . LineTo ( X , Y ); { draw line from PenPos to (X, Y) }
end ;
procedure TForm1 . FormMouseMove ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
Canvas . LineTo ( X , Y ); { draw line to current position }
end ;
type
TForm1 = class ( TForm )
procedure FormMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
procedure FormMouseUp ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
procedure FormMouseMove ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
public
Drawing : Boolean ;
Origin , MovePt : TPoint ; { fields to store points }
end ;
procedure TForm1 . FormMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
Drawing := True ; { set the Drawing flag }
Canvas . MoveTo ( X , Y );
end ;
procedure TForm1 . FormMouseUp ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
Canvas . LineTo ( X , Y );
Drawing := False ; { clear the Drawing flag }
end ;
procedure TForm1 . FormMouseMove ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
if Drawing then { only draw if Drawing flag is set }
Canvas . LineTo ( X , Y );
end ;
procedure TForm1 . FormMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
Drawing := True ;
Canvas . MoveTo ( X , Y );
Origin := Point ( X , Y ); { record where the line starts }
end ;
procedure TForm1 . FormMouseUp ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
Canvas . MoveTo ( Origin . X , Origin . Y ); { move pen to starting point }
Canvas . LineTo ( X , Y );
Drawing := False ;
end ;
procedure TForm1 . FormMouseMove ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
if Drawing then
begin
Canvas . MoveTo ( Origin . X , Origin . Y ); { move pen to starting point }
Canvas . LineTo ( X , Y );
end ;
end ;
procedure TForm1 . FormMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
Drawing := True ;
Canvas . MoveTo ( X , Y );
Origin := Point ( X , Y );
MovePt := Point ( X , Y ); { keep track of where this move was }
end ;
procedure TForm1 . FormMouseMove ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
if Drawing then
begin
Canvas . Pen . Mode := pmNotXor ; { use XOR mode to draw/erase }
Canvas . MoveTo ( Origin . X , Origin . Y ); { move pen back to origin }
Canvas . LineTo ( MovePt . X , MovePt . Y ); { erase the old line }
Canvas . MoveTo ( Origin . X , Origin . Y ); { start at origin again }
Canvas . LineTo ( X , Y ); { draw the new line }
end ;
MovePt := Point ( X , Y ); { record point for next move }
Canvas . Pen . Mode := pmCopy ;
end ;
procedure TForm1 . LineButtonClick ( Sender : TObject ); { LineButton }
begin
DrawingTool := dtLine ;
end ;
procedure TForm1 . RectangleButtonClick ( Sender : TObject ); { RectangleButton }
begin
DrawingTool := dtRectangle ;
end ;
procedure TForm1 . EllipseButtonClick ( Sender : TObject ); { EllipseButton }
begin
DrawingTool := dtEllipse ;
end ;
procedure TForm1 . RoundedRectButtonClick ( Sender : TObject ); { RoundRectButton }
begin
DrawingTool := dtRoundRect ;
end ;
procedure TForm1 . FormMouseUp ( Sender : TObject );
begin
if DrawingTool = dtLine then { draw a line }
else if DrawingTool = dtRectangle then { draw a rectangle }
{ ... and so on ... }
end ;
procedure TForm1 . FormMouseUp ( Sender : TObject );
begin
case DrawingTool of
dtLine : { draw a line }
dtRectangle : { draw a rectangle }
{ ... and so on ... }
end ;
end ;
procedure TForm1 . FormMouseUp ( Sender : TObject );
begin
case DrawingTool of
dtLine :
begin
Canvas . MoveTo ( Origin . X , Origin . Y );
Canvas . LineTo ( X , Y )
end ;
dtRectangle : Canvas . Rectangle ( Origin . X , Origin . Y , X , Y );
dtEllipse : Canvas . Ellipse ( Origin . X , Origin . Y , X , Y );
dtRoundRect : Canvas . RoundRect ( Origin . X , Origin . Y , X , Y ,
( Origin . X - X ) div 2 , ( Origin . Y - Y ) div 2 );
end ;
Drawing := False ;
end ;
procedure TForm1 . FormMouseMove ( Sender : TObject ; Shift : TShiftState ; X , Y : Integer );
begin
if Drawing then
begin
Canvas . Pen . Mode := pmNotXor ;
case DrawingTool of
dtLine : begin
Canvas . MoveTo ( Origin . X , Origin . Y );
Canvas . LineTo ( MovePt . X , MovePt . Y );
Canvas . MoveTo ( Origin . X , Origin . Y );
Canvas . LineTo ( X , Y );
end ;
dtRectangle : begin
Canvas . Rectangle ( Origin . X , Origin . Y , MovePt . X , MovePt . Y );
Canvas . Rectangle ( Origin . X , Origin . Y , X , Y );
end ;
dtEllipse : begin
Canvas . Ellipse ( Origin . X , Origin . Y , X , Y );
Canvas . Ellipse ( Origin . X , Origin . Y , X , Y );
end ;
dtRoundRect : begin
Canvas . RoundRect ( Origin . X , Origin . Y , X , Y ,
( Origin . X - X ) div 2 , ( Origin . Y - Y ) div 2 );
Canvas . RoundRect ( Origin . X , Origin . Y , X , Y ,
( Origin . X - X ) div 2 , ( Origin . Y - Y ) div 2 );
end ;
end ;
MovePt := Point ( X , Y );
end ;
Canvas . Pen . Mode := pmCopy ;
end ;
procedure TForm1 . PenButtonClick ( Sender : TObject );
begin
PenBar . Visible := PenButton . Down ;
end ;
procedure TForm1 . BrushButtonClick ( Sender : TObject );
begin
BrushBar . Visible := BrushButton . Down ;
end ;
procedure TForm1 . SetPenStyle ( Sender : TObject );
begin
with Canvas . Pen do
begin
if Sender = SolidPen then Style := psSolid
else if Sender = DashPen then Style := psDash
else if Sender = DotPen then Style := psDot
else if Sender = DashDotPen then Style := psDashDot
else if Sender = DashDotDotPen then Style := psDashDotDot
else if Sender = ClearPen then Style := psClear ;
end ;
end ;
procedure TForm1 . PenColorClick ( Sender : TObject );
begin
Canvas . Pen . Color := PenColor . ForegroundColor ;
end ;
procedure TForm1 . PenWidthChange ( Sender : TObject );
begin
Canvas . Pen . Width := PenWidth . Position ; { set the pen width directly }
PenSize . Caption := IntToStr ( PenWidth . Position ); { convert to string for caption }
end ;
procedure TForm1 . SetBrushStyle ( Sender : TObject );
begin
with Canvas . Brush do
begin
if Sender = SolidBrush then Style := bsSolid
else if Sender = ClearBrush then Style := bsClear
else if Sender = HorizontalBrush then Style := bsHorizontal
else if Sender = VerticalBrush then Style := bsVertical
else if Sender = FDiagonalBrush then Style := bsFDiagonal
else if Sender = BDiagonalBrush then Style := bsBDiagonal
else if Sender = CrossBrush then Style := bsCross
else if Sender = DiagCrossBrush then Style := bsDiagCross ;
end ;
end ;
procedure TForm1 . BrushColorClick ( Sender : TObject );
begin
Canvas . Brush . Color := BrushColor . ForegroundColor ;
end ;
procedure TForm1 . FormMouseDown ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
Drawing := True ;
Canvas . MoveTo ( X , Y );
Origin := Point ( X , Y );
MovePt := Origin ;
OriginPanel . Caption := Format ( 'Origin: (%d, %d)' , [ X , Y ]); { update status bar }
end ;
procedure TForm1 . FormMouseMove ( Sender : TObject ; Shift : TShiftState ; X , Y : Integer );
begin
if Drawing then
begin
DrawShape ( Origin , MovePt , pmNotXor );
MovePt := Point ( X , Y );
DrawShape ( Origin , Point ( X , Y ), pmNotXor );
end ;
CurrentPanel . Caption := Format ( 'Current: (%d, %d)' , [ X , Y ]); { update status bar }
end ;
procedure TForm1 . FormCreate ( Sender : TObject );
var
Bitmap : TBitmap ; { temporary variable to hold the bitmap }
begin
Bitmap := TBitmap . Create ; { construct the bitmap object }
Bitmap . Width := 200 ; { assign the initial width... }
Bitmap . Height := 200 ; { ...and the initial height }
Image . Picture . Graphic := Bitmap ; { assign the bitmap to the image control }
end ;
procedure TForm1 . FormMouseUp ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
if Drawing then
begin
DrawShape ( Origin , Point ( X , Y ), pmCopy );
Drawing := False ;
end ;
end ;
procedure TForm1 . Print1Click ( Sender : TObject );
begin
with Printer do
begin
BeginDoc ; { start printing }
Canvas . Draw ( 0 , 0 , Image . Picture . Graphic ); { draw Image at upper left of page }
EndDoc ; { finish printing }
end ;
end ;
procedure TForm1 . Open1Click ( Sender : TObject );
begin
if OpenDialog1 . Execute then
begin
CurrentFile := OpenDialog1 . FileName ;
Image . Picture . LoadFromFile ( CurrentFile );
end ;
end ;
procedure TForm1 . Save1Click ( Sender : TObject );
begin
if CurrentFile <> '' then
Image . Picture . SaveToFile ( CurrentFile ) { save if already named }
else SaveAs1Click ( Sender ); { otherwise get a name }
end ;
procedure TForm1 . Saveas1Click ( Sender : TObject );
begin
if SaveDialog1 . Execute then { get a file name }
begin
CurrentFile := SaveDialog1 . FileName ; { save the user-specified name }
Save1Click ( Sender ); { then save normally }
end ;
end ;
procedure TForm1 . New1Click ( Sender : TObject );
var
Bitmap : TBitmap ; { temporary variable for the new bitmap }
begin
with NewBMPForm do
begin
ActiveControl := WidthEdit ; { make sure focus is on width field }
WidthEdit . Text := IntToStr ( Image . Picture . Graphic . Width ); { use current dimensions... }
HeightEdit . Text := IntToStr ( Image . Picture . Graphic . Height ); { ...as default }
if ShowModal <> idCancel then { continue if user doesn't cancel dialog box }
begin
Bitmap := TBitmap . Create ; { create fresh bitmap object }
Bitmap . Width := StrToInt ( WidthEdit . Text ); { use specified width }
Bitmap . Height := StrToInt ( HeightEdit . Text ); { use specified height }
Image . Picture . Graphic := Bitmap ; { replace graphic with new bitmap }
CurrentFile := '' ; { indicate unnamed file }
end ;
end ;
end ;
procedure TForm1 . Copy1Click ( Sender : TObject );
begin
Clipboard . Assign ( Image . Picture );
end ;
var
ARect : TRect ;
begin
Copy1Click ( Sender ); { copy picture to Clipboard }
with Image . Canvas do
begin
CopyMode := cmWhiteness ; { copy everything as white }
ARect := Rect ( 0 , 0 , Image . Width , Image . Height ); { get bitmap rectangle }
CopyRect ( ARect , Image . Canvas , ARect ); { copy bitmap over itself }
CopyMode := cmSrcCopy ; { restore normal mode }
end ;
end ;
procedure TForm1 . PasteButtonClick ( Sender : TObject );
var
Bitmap : TBitmap ;
begin
if Clipboard . HasFormat ( CF_BITMAP ) then
{ check to see if there’s a bitmap on the clipboard )
begin
{create a bitmap to hold the contents on the clipboard }
Bitmap := TBitmap . Create ;
try
{ Get the bitmap off the clipboard using Assign }
Bitmap . Assign ( Clipboard );
{ Copy the bitmap to the Image }
Image . Canvas . Draw ( 0 , 0 , Bitmap );
finally
Bitmap . Free ;
end ;
end ;
end ;
procedure TFMForm . FormCreate ( Sender : TObject );
var
Drive , AddedIndex : Integer ;
begin
for Drive := 0 to 25 do { iterate through all possible drives }
if GetDriveType ( Drive ) > 0 then { positive values mean valid drives }
begin
AddedIndex := DriveTabSet . Tabs . Add ( Chr ( Drive + ord ( 'a' ))); { add a tab }
if Chr ( Drive + ord ( 'A' )) = FileList . Drive then { if it's current drive... }
DriveTabSet . TabIndex := AddedIndex ; { ...make that current tab }
end ;
end ;
procedure TFMForm . DirectoryOutlineChange ( Sender : TObject );
begin
FileList . Directory := DirectoryOutline . Directory ;
DirectoryPanel . Caption := DirectoryOutline . Directory ;
end ;
procedure TFMForm . FileListChange ( Sender : TObject );
var
TheFileName : string ;
begin
with FileList do
begin
if ItemIndex >= 0 then { is there a selected item? }
begin
TheFileName := Items [ ItemIndex ]; { get the file name }
FilePanel . Caption := Format ( '%s, %d bytes' , [ TheFileName ,
GetFileSize ( TheFileName )]); { set caption to file name/size }
end
else FilePanel . Caption := '' ; { blank panel if none selected }
end ;
end ;
procedure TFMForm . FormCreate ( Sender : TObject );
var
Drive , AddedIndex : Integer ;
DriveLetter : Char ;
begin
for Drive := 0 to 25 do { iterate through all possible drives }
begin
DriveLetter := Chr ( Drive + ord ( 'a' ));
case GetDriveType ( Drive ) of { positive values mean valid drives }
DRIVE_REMOVABLE : { add a tab }
AddedIndex := DriveTabSet . Tabs . AddObject ( DriveLetter , Floppy . Picture . Graphic );
DRIVE_FIXED : { add a tab }
AddedIndex := DriveTabSet . Tabs . AddObject ( DriveLetter , Fixed . Picture . Graphic );
DRIVE_REMOTE : { add a tab }
AddedIndex := DriveTabSet . Tabs . AddObject ( DriveLetter , Network . Picture . Graphic );
end ;
if UpCase ( DriveLetter ) = UpCase ( DirectoryOutline . Drive ) then { current drive? }
DriveTabSet . TabIndex := AddedIndex ; { then make that current tab }
end ;
end ;
procedure TFMForm . DriveTabSetMeasureTab ( Sender : TObject ; Index : Integer ;
var TabWidth : Integer ); { note that TabWidth is a var parameter}
var
BitmapWidth : Integer ;
begin
BitmapWidth := TBitmap ( DriveTabSet . Tabs . Objects [ Index ]). Width ;
{ increase tab width by the width of the associated bitmap plus two }
Inc ( TabWidth , 2 + BitmapWidth );
end ;
procedure TFMForm . DriveTabSetDrawTab ( Sender : TObject ; TabCanvas : TCanvas ;
R : TRect ; Index : Integer ; Selected : Boolean );
var
Bitmap : TBitmap ;
begin
Bitmap := TBitmap ( DriveTabSet . Tabs . Objects [ Index ]);
with TabCanvas do
begin
Draw ( R . Left , R . Top + 4 , Bitmap ); { draw bitmap }
TextOut ( R . Left + 2 + Bitmap . Width , { position text }
R . Top + 2 , DriveTabSet . Tabs [ Index ]); { and draw it to the right of the bitmap }
end ;
end ;
procedure TFMForm . File1Click ( Sender : TObject );
var
FileSelected : Boolean ;
begin
FileSelected := FileList . ItemIndex >= 0 ; { True if there is a file selected }
Open1 . Enabled := FileSelected ;
Delete1 . Enabled := FileSelected ;
Copy1 . Enabled := FileSelected ;
Move1 . Enabled := FileSelected ;
Rename1 . Enabled := FileSelected ;
Properties1 . Enabled := FileSelected ;
end ;
procedure TFMForm . Delete1Click ( Sender : TObject );
begin
with FileList do
if DeleteFile ( FileName ) then Update ;
end ;
procedure TFMForm . Delete1Click ( Sender : TObject );
begin
with FileList do
if MessageDlg ( 'Delete ' + FileName + '?' , mtConfirmation ,
[ mbYes , mbNo ], 0 ) = mrYes then
if DeleteFile ( FileName ) then Update ;
end ;
procedure TFMForm . Properties1Click ( Sender : TObject );
var
Attributes , NewAttributes : Word ;
begin
with FileAttrForm do
begin
FileDirName . Caption := FileList . Items [ FileList . ItemIndex ]; { set box caption }
PathName . Caption := FileList . Directory ; { show directory name }
ChangeDate . Caption := DateTimeToStr ( FileDateTime ( FileList . FileName ));
Attributes := FileGetAttr ( FileDirName . Caption ); { read file attributes }
ReadOnly . Checked := ( Attributes and faReadOnly ) = faReadOnly ;
Archive . Checked := ( Attributes and faArchive ) = faArchive ;
System . Checked := ( Attributes and faSysFile ) = faSysFile ;
Hidden . Checked := ( Attributes and faHidden ) = faHidden ;
if ShowModal <> mrCancel then { execute dialog box }
begin
NewAttributes := Attributes ; { start with original attributes }
if ReadOnly . Checked then NewAttributes := NewAttributes or faReadOnly
else NewAttributes := NewAttributes and not faReadOnly ;
if Archive . Checked then NewAttributes := NewAttributes or faArchive
else NewAttributes := NewAttributes and not faArchive ;
if System . Checked then NewAttributes := NewAttributes or faSysFile
else NewAttributes := NewAttributes and not faSysFile ;
if Hidden . Checked then NewAttributes := NewAttributes or faHidden
else NewAttributes := NewAttributes and not faHidden ;
if NewAttributes <> Attributes then { if anything changed... }
FileSetAttr ( FileDirName . Caption , NewAttributes ); { ...write the new values }
end ;
end ;
end ;
procedure TFMForm . ConfirmChange ( const ACaption , FromFile , ToFile : string );
begin
if MessageDlg ( Format ( '%s %s to %s?' , [ ACaption , FromFile , ToFile ]),
mtConfirmation , [ mbYes , mbNo ], 0 ) = mrYes then
begin
if ACaption = 'Move' then
MoveFile ( FromFile , ToFile )
else if ACaption = 'Copy' then
CopyFile ( FromFile , ToFile )
else if ACaption = 'Rename' then
RenameFile ( FromFile , ToFile );
FileList . Update ;
end ;
end ;
procedure TFMForm . FileChange ( Sender : TObject );
begin
with ChangeDlg do
begin
if Sender = Move1 then Caption := 'Move'
else if Sender = Copy1 then Caption := 'Copy'
else if Sender = Rename1 then Caption := 'Rename'
else Exit ;
CurrentDir . Caption := DirectoryOutline . Directory ;
FromFileName . Text := FileList . FileName ;
ToFileName . Text := '' ;
if ( ShowModal <> mrCancel ) and ( ToFileName . Text <> '' ) then
ConfirmChange ( Caption , FromFileName . Text , ToFileName . Text );
end ;
end ;
procedure TFMForm . Open1Click ( Sender : TObject );
begin
with FileList do
ExecuteFile ( FileName , '' , Directory , SW_SHOW );
end ;
procedure TFMForm . Open1Click ( Sender : TObject );
begin
with FileList do
begin
if HasAttr ( FileName , faDirectory ) then
DirectoryOutline . Directory := FileName
else ExecuteFile ( FileName , '' , Directory , SW_SHOW );
end ;
end ;
procedure TFMForm . FileListBox1MouseDown ( Sender : TObject ;
Button : TMouseButton ; Shift : TShiftState ; X , Y : Integer );
begin
if Button = mbLeft then { drag only if left button pressed }
with Sender as TFileListBox do { treat Sender as TFileListBox }
begin
if ItemAtPos ( Point ( X , Y ), True ) >= 0 then { is there an item here? }
BeginDrag ( False ); { if so, drag it }
end ;
end ;
procedure TFMForm . DirectoryOutline1DragOver ( Sender , Source : TObject ; X ,
Y : Integer ; State : TDragState ; var Accept : Boolean );
begin
if Source is TFileListBox then
Accept := True ;
end ;
procedure TFMForm . DirectoryOutline1DragDrop ( Sender , Source : TObject ; X ,
Y : Integer );
begin
if Source is TFileListBox then
with DirectoryOutline do
ConfirmChange ( 'Move' , FileList . FileName , Items [ GetItem ( X , Y )]. FullPath );
end ;
procedure TFMForm . FileListBox1EndDrag ( Sender , Target : TObject ; X , Y : Integer );
begin
if Target <> nil then FileList . Update ;
end ;
procedure TOLEFrameForm . New1Click ( Sender : TObject );
begin
CreateChild {Call the CreateChild method}
end ;
procedure TOLEFrameForm . Exit1Click ( Sender : TObject );
begin
Close {close the main form, which terminates the application}
end ;
procedure TOLEObjectForm . New1Click ( Sender : TObject );
begin
OLEFrameForm . New1Click ( Sender ) {Call OLEFrameForm's File|New handler}
end ;
procedure TOLEObjectForm . Exit1Click ( Sender : TObject );
begin
OLEFrameForm . Exit1Click ( Sender ) {Call OLEFrameForm's File|Exit handler}
end ;
procedure TOLEObjectForm . Cascade1Click ( Sender : TObject );
begin
OLEFrameForm . Cascade {Cascade the MDI children of OLEFrameForm}
end ;
procedure TOLEObjectForm . Tile1Click ( Sender : TObject );
begin
OLEFrameForm . Tile {Tile the MDI children of OLEFrameForm}
end ;
procedure TOLEObjectForm . ArrangeIcons1Click ( Sender : TObject );
begin
OLEFrameForm . ArrangeIcons {Arrange the icons of the MDI chilren of OLEFrameForm}
end ;
procedure TOLEObjectForm . OleContainerStatusLineEvent ( Sender : TObject ; Msg : String );
begin
OLEFrameForm . StatusBarPanel . Caption := Msg {Display Msg in status bar}
end ;
procedure TOLEObjectForm . InitializeOLEObject ( Info : Pointer );
begin
OLEContainer . PInitInfo := Info ; {Initialize the container by pointing to Info}
ReleaseOLEInitInfo ( Info )
end ;
procedure TOLEObjectForm . InsertObject1Click ( Sender : TObject );
var
Info : Pointer ; {Declare the pointer to the OLE initialization info}
begin
if InsertOLEObjectDlg ( OLEFrameForm , 0 , Info ) then {Insert Object dialog box}
InitializeOLEObject ( Info ); {Initialize the OLE object}
end ;
procedure TOLEObjectForm . Deactivate1Click ( Sender : TObject );
begin
OLEContainer . Active := False {Deactivate the OLE object}
end ;
procedure TOLEFrameForm . FormCreate ( Sender : TObject );
begin
FEmbedClipFmt := RegisterClipboardFormat ( 'Embedded Object' );
FLinkClipFmt := RegisterClipboardFormat ( 'Link Source' );
end ;
procedure TOLEFrameForm . FormCreate ( Sender : TObject );
begin
FEmbedClipFmt := RegisterClipboardFormat ( 'Embedded Object' );
FLinkClipFmt := RegisterClipboardFormat ( 'Link Source' );
Fmts [ 0 ]. fmtId := FEmbedClipFmt ; {Embedded OLE object Clipboard format}
Fmts [ 0 ]. fmtMedium := BOLEMediumCalc ( FEmbedClipFmt ); {Medium for embedded objects}
Fmts [ 0 ]. fmtIsLinkable := False ; {No linking to OLE server}
StrPCopy ( Fmts [ 0 ]. fmtName , '%s' ); {Name from OLE server}
StrPCopy ( Fmts [ 0 ]. fmtResultName , '%s' ); {Result name from OLE server}
Fmts [ 1 ]. fmtId := FLinkClipFmt ; {Linked OLE object Clipboard format}
Fmts [ 1 ]. fmtMedium := BOLEMediumCalc ( FLinkClipFmt ); {Medium for linked objects}
Fmts [ 1 ]. fmtIsLinkable := True ; {Allows linking to OLE server}
StrPCopy ( Fmts [ 1 ]. fmtName , '%s' ); {Name from OLE server}
StrPCopy ( Fmts [ 1 ]. fmtResultName , '%s' ); {Result name from OLE server}
end ;
procedure TOLEObjectForm . PasteSpecial1Click ( Sender : TObject );
var
ClipFmt : Word ; {Declare the Windows Clipboard format variable}
DataHand : THandle ; {Declare the Windows Clipboard data handle variable}
Info : Pointer ; {Declare the pointer to the OLE initialization info}
begin
if PasteSpecialEnabled ( Self , OLEFrameForm . Fmts ) then {If there is something to paste}
if PasteSpecialDlg ( OLEObjectForm , OLEFrameForm . Fmts , 0 , {Paste Special dialog box}
ClipFmt , DataHand , Info ) then
InitializeOLEObject ( Info ) {Initialize the OLE object}
end ;
procedure TOLEObjectForm . Edit1Click ( Sender : TObject );
begin
PasteSpecial1 . Enabled := PasteSpecialEnabled ( Self , OLEFrameForm . Fmts )
end ;
procedure TOLEFrameForm . FormDragDrop ( Sender , Source : TObject ; X , Y : Integer );
var
NewChild : TOLEObjectForm ;
begin
if Source is TOLEDropNotify then
begin
NewChild := CreateChild ;
with Source as TOLEDropNotify do
NewChild . OLEContainer . PInitInfo := PInitInfo ;
end
end ;
procedure TOLEObjectForm . Saveas1Click ( Sender : TObject );
begin
if SaveAsDialog . Execute then
OLEContainer . SaveToFile ( SaveAsDialog . FileName ) {Save the object to FileName}
end ;
procedure TOLEFrameForm . Open1Click ( Sender : TObject );
var
NewChild : TOLEObjectForm ;
begin
if OpenDialog . Execute then
begin
NewChild := CreateChild ;
NewChild . OLEContainer . LoadFromFile ( OpenDialog . FileName )
end
end ;
procedure TOLEObjectForm . Open1Click ( Sender : TObject );
begin
OLEFrameForm . Open1Click ( Sender )
end ;
Delphi - .....................................
