Mega Code Archive
Püf
<![CDATA[
Ek Bölüm : Delphi'de PÜF Noktaları
PÜF İNDEKSİ
1. VERI TABANI - BDE (7 - 105)
1) TTABLE/TQUERY ÜZERINDE ARTTIRARAK ARAMA 7
2) PARADOX-TABLO YARATILMASI 8
3) DBMEMO IÇERIĞININ BAŞKA BIR DBMEMO BILEŞENINE AKTARILMASI 8
4) TDBNAVIGATOR BILEŞENIN, KOD IÇERISINDEN KONTROL EDILMESI 8
5) DBMEMO IÇERISINDE BIR METNIN ARANMASI 9
6) BIR TABLONUN ALAN BILGILERININ ELDE EDILMESI 14
7) TDBGRID BILEŞENI ÜZERINDE, KAYIT SIRALAMA 20
8) MEVCUT TABLODAKI KOLONLARIN ELENMESI 20
9) BIR TABLODAKI TMEMOFIELD TIPLI BIR ALAN IÇERIĞININ, TMEMO BILEŞENINE AKTARILMASI 20
10) BIR PARADOX TABLOSUNA IKINCI İNDEKS EKLENMESI 21
11) DBGRID KOLONLARI ÜZERINDE DOLAŞMA 21
12) DETAYI OLAN BIR TABLODAN KAYIT SILME 21
13) DBGRID VE MEMO ALANLAR 22
14) TABLO IÇERIĞININ TSTRINGRID BILEŞENINE DOLDURULMASI 23
15) TTABLE VEYA TQUERY ÜZERINDEN KAYIT NUMARASININ BULUNMASI 23
16) DBASE TABLOLARINDAN SILINMIŞ KAYITLARIN ATILMASI 29
17) UYGULAMA IÇERISINDEN BDE KOD ADI (ALIAS) YARATILMASI 30
18) BDE KOD ADI (ALIAS) PARAMETRELERININ ELDE EDILMESI 31
19) BIR DBASE (.DBF) TABLOSUNDAKI SILINMIŞ KAYITLARIN GÖRÜNTÜLENMESI 31
20) BIR TABLODAKI ALAN SAYISININ BULUNMASI 37
21) BIR TABLODAKI VERININ, BAŞKA BIR TABLOYA EKLENMESI 39
22) SORGUDAN TABLO YARATILMASI 40
23) SORGUDAN TABLOYA VERI AKTARIMI 41
24) TABLODAKI BIR ALANA AIT VERILERIN, BAŞKA BIR ALANA KOPYALANMASI 42
25) TABLO KOPYALAMA 44
26) TABLO SILME 49
27) ALAN ADININ BULUNMASI 50
28) ORTAK ALAN ISIMLERI 51
29) TABLODAKI ALAN ISIMLERI 53
30) ALAN NUMARASI 54
31) ALAN UZUNLUĞU 55
32) ALAN TIPLERI 56
33) TABLONUN ANAHTAR ALANLARI 59
34) LOOKUP YÖNTEMIYLE DEĞER SEÇME DIYALOĞU 60
35) BIR PARADOX TABLOSUNUN YENIDEN ANAHTARLANMASI 68
36) TABLO ADININ DEĞIŞTIRILMESI 71
37) TABLO YAPILARI AYNI MI? 74
38) BIR TABLO ALANINDAKI DEĞERLERIN SAĞ TARAFINDAKI BOŞLUKLARIN TEMIZLENMESI 75
39) ARANAN ALAN, TABLODA VAR MI? 76
40) ALAN ANAHTAR MI? 78
41) TABLO MEVCUT MU? 81
42) TABLO MEVCUT VE ESAS ANAHTARI VAR MI 82
43) MEVCUT BIR TABLO ILE AYNI YAPIDA BAŞKA BIR TABLO YARATMAK 84
44) TABLO FILTRELEME 86
45) ŞIFRELI PARADOX TABLOSUNA OTOMATIK BAĞLANTI 88
46) SUBSTRING FONKSIYONUNUN SQL CÜMLESINDE KULLANILMASI 88
47) DBCONTROLGRID KAYDIRMA ÇUBUKLARI 89
48) TABLODAN DOSYAYA AKTARMA 91
49) SORGUDAN DOSYAYA AKTARMA 94
50) ÖZEL BIR DBGRID 98
51) DBNAVIGATOR BUTONLARINA ERIŞIM 104
2. AĞ IŞLEMLERI (106 - 115)
52) AĞ SÜRÜCÜLERI 106
53) AĞ DA TANIMLI KULLANICILAR KIMLER? 108
54) TANIMLI AĞ SÜRÜCÜLERI 112
3. SES VE GRAFIK IŞLEMLERI (114 - 159)
55) FARKLI ÇIZGILER 115
56) STRINGGRID IÇERISINDE BMP 116
57) TONLAMALI(GRADIENT) FORM 119
58) EKRAN YAKALAMA 120
59) BIR RESMI, BMP FORMATINDAN JPEG FORMATINA ÇEVIRME 121
60) DUVAR KAĞIDI DEĞIŞTIRME 121
61) SISTEMIN KULLANABILECEĞI RENK SAYISININ BULUNMASI 122
62) DBGRID ALANLARININ RENKLENDIRILMESI 122
63) LISTBOX BILEŞENLERINDE RENKLI SATIRLAR 123
64) RENK PALETLERININ YARATILMASI VE KULLANIMI 124
65) MÜZIK CD SI ÇALINIRKEN, TRACK SAYISININ OKUNMASI 128
66) EKRAN ÇÖZÜNÜRLÜĞÜ DEĞIŞTIRME 130
67) BMP RESMININ PANOYA YAPIŞTIRILMASI VE PANODAN KOPYALAMASI 135
68) BIR EXE DEN IKONUN ALINIP BAŞKA BIR YERE ÇIZILMESI 138
69) İKON RESMININ, BUTON ÜZERINDE KULLANILMASI 139
70) GRAFIK ÇIZME IŞLEMI 142
71) HAREKETLI GRAFIK ÇIZIMI 143
72) PANOYA RESIM KOPYALAMA 146
73) BIR REMIN ŞEFFAF OLARAK BAŞKA BIR RESIM ÜZERINE YAPIŞTIRILMASI 147
74) PALET DEĞIŞTIRME 153
75) PANODAKI METNIN DISKTEKI BIR DOSYAYA KAYDEDILMESI 158
4. FORM VE PENCERE IŞLEMLERI (160 - 186)
76) MASA ÜSTÜNDEKI IKONLARIN SAKLANMASI 161
77) BÜTÜN AÇIK PENCERELERIN LISTELENMESI 165
78) FARKLI BIR PENCERE 166
79) ÜZERINE BIRAKILAN DOSYALARA DUYARLI FORM 167
80) FORM BAŞLIĞININ SAKLANMASI 169
81) STANDART DIŞI FORMLAR 169
82) FORM POZÜSYONU 173
83) EKRAN ÇÖZÜNÜRLÜĞÜ 174
84) FORM BAŞLIK ALANI ÜZERINDE SAAT GÖSTERILMESI 176
85) FORM BAŞLIĞININ GIZLENMESI 177
86) FORMUN BAŞLIK ALANINA BUTON YERLEŞTIRME 180
87) AÇILIR-KAPANIR FORM 184
88) PENCERENIN TAŞINMASI 186
5. DISK VE DOSYA IŞLEMLERI (186 - 212)
89) SÜRÜCÜ LISTESI 186
90) DISKET SÜRÜCÜSÜNDE DISKET TAKILI MI ? 188
91) ÇALIŞAN UYGULAMANIN BULUNDUĞU DIZIN 188
92) WINDOWS'UN STANDART "BROWSEFOLDER" DIYALOG PENCERESININ KULLANILMASI 189
93) BIR DIZINDEKI DOSYALARIN VE ALT DIZINLERIN TÜMÜNÜN SILINMESI 191
94) DOSYA KOPYALAMA 192
95) İKILI DOSYADAN OKUMA 194
96) BIR DOSYANIN SALT OKUNUR OLARAK AÇILMASI 194
97) SATIR SONU KARAKTERININ ASCII KODU NEDIR? 194
98) DISK SERI NUMARASI VE ETIKETININ OKUNMASI 194
99) DOSYANIN SÜRÜKLENIP BIRAKILMASI 203
100) WINDOWS GEÇICI KLASÖRÜNÜN BULUNMASI 205
101) WINDOWS SISTEM DIZINININ BULUNMASI 206
102) DOSYA YARATILMA TARIHI 206
103) DOSYANIN SON KULLANILDIĞI TARIH 207
104) DOSYANIN SON DEĞIŞTIRILDIĞI TARIH 208
105) DIZIN BOŞ MU? 208
106) DOSYA UZANTISI HANGI PROGRAMLA BAĞLANTILI? 209
107) GERI DÖNÜŞÜM KUTUSUNA GÖNDER 211
6. GENEL (213 - 323)
108) KARAKTER DIZISI KARŞILAŞTIRMA 213
109) YÜKLENMIŞ DLL DOSYALARININ HAFIZADAN ATILMASI 215
110) BIR DOS KOMUTUNUN KULLANILMASI 216
111) TEDIT METNININ, ONCHANGE OLAYINDA DEĞIŞTIRILMESI 218
112) TMEMO BILEŞENINDE, IMLEÇ HANGI SATIRDA? 218
113) ULUSAL AYARLAR 218
114) TEDITBOX BILEŞENINDEKI METNIN ILK KARAKTERININ, BÜYÜK HARFE ÇEVIRILMESI 219
115) WINDOWS'UN KAPANMA ANININ TESPITI 219
116) BIR MEMO VEYA RICHEDIT BILEŞENINDE, IMLECIN ISTENEN YERE GÖNDERILMESI 223
117) WINDOWS ÇEVIRMELI AĞ BAĞLANTI PENCERESININ ÇAĞIRILMASI 223
118) OTOMATIK E-MAIL 223
119) MONITÖRÜN KAPATILMASI/AÇILMASI 223
120) WINDOWS'UN KAPATILMASI/YENIDEN BAŞLATILMASI 224
121) SISTEMDE SES KARTI VAR MI? 224
122) PROGRAMIN ARKA PLANDA ÇALIŞTIRILMASI 225
123) WINDOWS GÖREV ÇUBUĞUNUN GIZLENMESI/GÖSTERILMESI 228
124) ÇALIŞAN PROGRAMIN, GÖREV ÇUBUĞU ÜZERINDEN KALDIRILMASI 228
125) OCX'KULLANIMI 229
126) EKRAN ÇÖZÜNÜRLÜĞÜNDEKI DEĞIŞIKLIKLERIN TESPITI 231
127) PANO GÖRÜNTÜLEME 232
128) CPU BILGILERI 234
129) ENTER TUŞUNUN TAB YERINE KULLANILABILECEĞI BIR TEDIT BILEŞENI 251
130) TARIH DOĞRU MU 254
131) AYDA KAÇ GÜN VAR? 254
132) GEÇEN HAFTANIN ILK GÜNÜ 255
133) SONRAKI AYIN ILK GÜNÜ 255
134) SONRAKI HAFTANIN ILK GÜNÜ 255
135) HAFTANIN ILK GÜNÜ 256
136) AYIN SON GÜNÜ 256
137) AY 256
138) GELECEK AY 257
139) GEÇEN AY 257
140) GÜN SONRA 258
141) GELECEK AY 258
142) ÖNCEKI GÜN 258
143) GEÇEN HAFTA 259
144) METIN IÇERISINDEN BIR KARAKTER SILME 259
145) METIN IÇERISINDEN, BIR KARAKTERI DEĞIŞTIRME 259
146) BIR METNI BELLI BIR UZUNLUĞA TAMAMLAMA 260
147) METIN DEĞIŞTIRME 262
148) PROGRAM IÇERISINDEN, BAŞKA BIR UYGULAMAYA TUŞ GÖNDERME 263
149) PROGRAMI DENEME SÜRÜMÜ HALINE GETIRME 263
150) LISTBOX BILEŞENINE YATAY KAYDIRMA ÇUBUĞU EKLENMESI 264
151) KONTROL PANEL APPLETLERININ DELPHI IÇERISINDEN KULLANILMASI 265
152) SISTEM TARIH/SAAT AYARININ DEĞIŞTIRILMESI 266
153) EKRAN KORUYUCUNUN DEVREDEN ÇIKARILMASI 268
154) PROGRAMIN, WINDOWSUN BAŞLANGICINDA ÇALIŞTIRILMASI 269
155) HATA MESAJI KONTROLÜ 270
156) EKRAN KORUYUCU KURULMASI 271
157) LISTBOX YAZI TIPININ DEĞIŞTIRILMESI 271
158) TAŞINABILIR PANEL 271
159) CD-ROM KAPAĞININ KAPATILMASI 272
160) ÇALIŞMA ESNASINDA, BILEŞEN SAYISININ KONTROLÜ 273
161) FARE IMLECININ, ISTENEN KONTROL ÜZERINE GETIRILMESI 274
162) ALT-? TUŞ KOMBINASYONU 274
163) PROGRAMIN DURAKLATILMASI 276
164) YAZI KARAKTERI STILININ DEĞIŞTIRILMESI 277
165) MEVCUT BIR DAVRANIŞIN DEĞIŞTIRILMESI 277
166) KES, KOPYALA, YAPŞTIR 278
167) FARE IMLECININ, PENCERE ÜZERINDE OLUP OLMADIĞININ KONTROLÜ 278
168) GETKEYBOARDSTATE 279
169) OLAY YAKALAMA YORDAMLARININ DINAMIK OLARAK ATANMASI 280
170) SENDER PARAMETRESININ KULLANILMASI 281
171) BÜYÜK METINLERIN PANODAN ALINMASI 281
172) WINDOWS SÜRÜM NUMARASININ OKUNMASI 282
173) PROGRAM GURUPLARININ LISTBOX BILEŞENINE DOLDURULMASI 282
174) TLISTBOX VE TCOMBOBOX BILEŞENLERI IÇERISINE RESIM YERLEŞTIRILMESI 286
175) BASIT BIR DLL ŞABLONU 291
176) İPUCU PENCEREININ ÖZELLEŞTIRILMESI 292
177) DIZI SABITI TANIMI 293
178) STRINGRID BILEŞENI IÇERISINDEKI METNIN HIZALAMASI 293
179) TSTRINGGRID BILEŞENINDEN BIR SATIRIN SILINMESI 294
180) TSTRINGGRID SATIRININ EN ALTA GÖNDERILMESI 295
181) SISTEMDE TANIMLI YAZICILARIN LISTELENMESI 295
182) YAZDIRMA 296
183) ISTENEN YAZICININ SEÇIMI 296
184) YAZICI YAZI TIPLERI 297
185) HEX->DEC 297
186) HAFIZA MIKTARI 298
187) FARE HAREKET ALANININ KISITLANMASI 299
188) PGUP VE PGDOWN TUŞLARI ILE FORMU AŞAĞI YUKARI KAYDIRMA 301
189) ÖZEL YAZI KARAKTERI 302
190) EKRAN KORUYUCU 304
191) BIR NESNEDEKI ÖZELLIKLERIN LISTESI 310
192) HABERLEŞME PORTLARINA ERIŞIM 310
193) BILEŞEN ÖZELLIKLERININ KAYIT DEFTERINDE SAKLANMASI 311
194) LISTBOX IÇERISINDE ARTAN ARAMA 317
195) SISTEM MENÜSÜNÜN GELIŞTIRILMESI 318
196) BIR TEDIT.TEXT BILGISINDEKI DEĞIŞIKLIĞIN FARKEDILMESI 320
197) COMBOBOX BILEŞENININ, IÇINE GIRILDIĞINDE AÇILMASI VE KAPANMASI 321
198) YAZICIYA DOĞRUDAN BASKI GÖNDERME IŞLEMI 321
199) BILGISAYARI KAPATIP YENIDEN BAŞLATMA 323
1. Veri Tabanı/BDE
Bu başlık altında, Delphi programlarında veri tabanı ve veri erişiminde kullanılan bileşenler ile ilgili püf noktaları ve gerekli kod örnekleri yer almaktadır.
Ttable/TQuery üzerinde arttırarak arama
Tedit kullanarak, Ttable üzerinde arttırmalı arama yapmak için, Tedid bileşeninin OnChange olay yordamına, aşğıdaki kod yazılır.
procedure TForm1.Edit1Change(Sender: TObject);
begin
With Edit1 do
if Text <> '' then
Table1.FindNearest([Text]);
end;
Bu türlü bir arama Tquerry üzerinde yapılacaksa,
procedure TForm1.Edit1Change(Sender: TObject);
begin
With Edit1 do
if Text <> '' then begin
Query1.Filter := 'code = '''+Edit1.Text+'''';
Query1.FindFirst;
end;
end;
veya
procedure TForm1.Edit1Change(Sender: TObject);
begin
With Edit1 do
if Text <> '' then
Query1.Locate('code',Edit1.Text,[loPartialKey]);
end;
Paradox-Tablo yaratılması
Kod içerisinden bir Paradox tablosu şu şekilde yaratılır.
with TTable.create(self) do begin
DatabaseName := 'C:\temp';
TableName := 'FOO';
TableType := ttParadox;
with FieldDefs do Begin
Add('Age', ftInteger, 0, True);
Add('Name', ftString, 25, False);
Add('Weight', ftFloat, 0, False);
End;
IndexDefs.Add('MainIndex','IntField', [ixPrimary, ixUnique]);
CreateTable;
End;
DBMemo içeriğinin başka bir DBMemo bileşenine aktarılması
DBMemo6.Lines:=DBMemo5.Lines.Assign;
TDBNavigator bileşenin, kod içerisinden kontrol edilmesi
procedure TForm1.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
var
BtnName: string;
begin
case Button of
nbFirst : BtnName := 'nbFirst';
nbPrior : BtnName := 'nbPrior';
nbNext : BtnName := 'nbNext';
nbLast : BtnName := 'nbLast';
nbInsert : BtnName := 'nbInsert';
nbDelete : BtnName := 'nbDelete';
nbEdit : BtnName := 'nbEdit';
nbPost : BtnName := 'nbPost';
nbCancel : BtnName := 'nbCancel';
nbRefresh: BtnName := 'nbRefresh';
end;
MessageDlg(BtnName + ' button clicked.', mtInformation, [mbOK], 0);
end;
DBMemo içerisinde bir metnin aranması
procedure Tform1.FindDialog1Find(Sender: TObject);
var Buff, P, FT : PChar;
BuffLen : Word;
begin
With Sender as TFindDialog do
begin
GetMem(FT, Length(FindText) + 1);
StrPCopy(FT, FindText);
BuffLen:= DBMemo1.GetTextLen + 1;
GetMem(Buff,BuffLen);
DBMemo1.GetTextBuf(Buff,BuffLen);
P:= Buff + DBMemo1.SelStart + DBMemo1.SelLength;
P:= StrPos(P, FT);
if P = NIL then MessageBeep(0)
else
begin
DBMemo1.SelStart:= P - Buff;
DBMemo1.SelLength:= Length(FindText);
end;
FreeMem(FT, Length(FindText) + 1);
FreeMem(Buff,BuffLen);
DBMemo1.SetFocus;
end;
end;
Şekil 1 : Form1
kod örneği 1 : form1.dfm
object Form1: TForm1
Left = 200
Top = 108
Width = 696
Height = 445
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 96
TextHeight = 13
object DBMemo1: TDBMemo
Left = 16
Top = 152
Width = 657
Height = 193
DataField = 'Notes'
DataSource = DataSource1
TabOrder = 0
OnDblClick = DBMemo1DblClick
end
object DBGrid1: TDBGrid
Left = 16
Top = 16
Width = 657
Height = 120
DataSource = DataSource1
TabOrder = 1
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'MS Sans Serif'
TitleFont.Style = []
end
object DBNavigator1: TDBNavigator
Left = 432
Top = 352
Width = 240
Height = 25
TabOrder = 2
end
object DataSource1: TDataSource
DataSet = Table1
Left = 138
Top = 364
end
object Table1: TTable
Active = True
DatabaseName = 'dbdemos'
TableName = 'BIOLIFE.DB'
Left = 220
Top = 366
end
object FindDialog1: TFindDialog
OnFind = FindDialog1Find
Left = 40
Top = 360
end
end
kod örneği 2 : unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, Grids, DBGrids, Db, DBTables, DBCtrls, ExtCtrls;
type
TForm1 = class(TForm)
DBMemo1: TDBMemo;
DataSource1: TDataSource;
Table1: TTable;
DBGrid1: TDBGrid;
FindDialog1: TFindDialog;
DBNavigator1: TDBNavigator;
procedure FindDialog1Find(Sender: TObject);
procedure DBMemo1DblClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure Tform1.FindDialog1Find(Sender: TObject);
var Buff, P, FT : PChar;
BuffLen : Word;
begin
With Sender as TFindDialog do
begin
GetMem(FT, Length(FindText) + 1);
StrPCopy(FT, FindText);
BuffLen:= DBMemo1.GetTextLen + 1;
GetMem(Buff,BuffLen);
DBMemo1.GetTextBuf(Buff,BuffLen);
P:= Buff + DBMemo1.SelStart + DBMemo1.SelLength;
P:= StrPos(P, FT);
if P = NIL then MessageBeep(0)
else
begin
DBMemo1.SelStart:= P - Buff;
DBMemo1.SelLength:= Length(FindText);
end;
FreeMem(FT, Length(FindText) + 1);
FreeMem(Buff,BuffLen);
DBMemo1.SetFocus;
end;
end;
procedure TForm1.DBMemo1DblClick(Sender: TObject);
begin
finddialog1.execute;
end;
end.
Bir tablonun alan bilgilerinin elde edilmesi
Ttable bileşeninden yola çıkarak, bağlı olduğu tablonun alan bilgileri "FieldDefs" özelliği sayesinde elde edilebilir. GetFieldNames davranışı alan isimlerini, GetIndexNames davranışı ise tabloda mevcut olan indeks isimlerini döndürür.
Şekil 2 : form1
kod örneği 3 : form1.dfm
object Form1: TForm1
Left = 200
Top = 108
Width = 425
Height = 340
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 16
Top = 136
Width = 43
Height = 13
Caption = 'İndeksler'
end
object Label2: TLabel
Left = 16
Top = 0
Width = 32
Height = 13
Caption = 'Alanlar'
end
object Label3: TLabel
Left = 232
Top = 0
Width = 122
Height = 13
Caption = 'Alan isimleri ve uzunlukları'
end
object Memo1: TMemo
Left = 232
Top = 16
Width = 169
Height = 249
Lines.Strings = (
'Memo1')
TabOrder = 0
end
object Button1: TButton
Left = 240
Top = 272
Width = 153
Height = 25
Caption = 'Alan isimleri ve uzunlukları'
TabOrder = 1
OnClick = Button1Click
end
object Button2: TButton
Left = 16
Top = 272
Width = 201
Height = 25
Caption = 'Alan ve İndeks isimleri '
TabOrder = 2
OnClick = Button2Click
end
object ListBox1: TListBox
Left = 16
Top = 16
Width = 201
Height = 113
ItemHeight = 13
TabOrder = 3
end
object ListBox2: TListBox
Left = 16
Top = 152
Width = 201
Height = 113
ItemHeight = 13
TabOrder = 4
end
object Table1: TTable
DatabaseName = 'dbdemos'
TableName = 'ANIMALS.DBF'
Left = 104
Top = 72
end
kod örneği 4 : unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, Db, DBTables;
type
TForm1 = class(TForm)
Memo1: TMemo;
Table1: TTable;
Button1: TButton;
Button2: TButton;
ListBox1: TListBox;
ListBox2: TListBox;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure ShowFields;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.ShowFields;
var
i : Word;
begin
Memo1.Lines.Clear;
Table1.FieldDefs.Update;
for i := 0 to Table1.FieldDefs.Count - 1 do
With Table1.FieldDefs.Items[i] do
Memo1.Lines.Add(Name + ' - ' + IntToStr(Size));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
showfields;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
If Table1.State = dsInactive then Table1.Open;
Table1.GetFieldNames(listbox1.items);
Table1.GetIndexNames(listbox2.items);
end;
end.
TDBGrid bileşeni üzerinde, kayıt sıralama
Eğer bir Interbase tablosu ile çalışılıyor ise, Dbgrid üzerinde seçilen kolon başlığına göre verilerin sıralanması mümkündür.
procedure TForm1.DBGrid1CellClick(Column: TColumn);
begin
if checkbox1.checked then
with dbgrid1.datasource.dataset as ttable do
indexfieldnames:=column.field.fieldname;
end;
Mevcut tablodaki kolonların elenmesi
Bir tablodaki alanların "Visible" özelliğine "False" değeri verilerek, istenmeyen alanların görüntülenmesi engellenir.
Table1.FieldByName(<saklanacak alanb adı>).Visible := False;
veya
Table1.Field[<saklanacak alan no>].Visible := false;
Bir tablodaki TMemoField tipli bir alan içeriğinin, TMemo bileşenine aktarılması
Procedure TMemoToTMemoField;
begin
TMemoField.Assign( TMemo.Lines );
end;
Procedure TMemoFieldToTMemo;
VAR aBlobStream : TBlobStream;
Begin
aBlobStream := TBlobStream.Create(tblobfield(table1.fieldbyname('Notes')), bmRead);
Memo1.Lines.LoadFromStream( aBlobStream );
aBlobStream.Free;
end;
Bir Paradox tablosuna ikinci İndeks eklenmesi
Table1.AddIndex('<indeks adı>', 'CustNo;CustName', [ixDescending]);
DBGrid kolonları üzerinde dolaşma
dbgrid1.selectedindex:=dbgrid1.selectedindex+1;
dbgrid1.setfocus;
Detayı olan bir tablodan kayıt silme
Master-Detay ilişki içerisindeki tablolarda, detayı olan bir ana kayıt silindiğinde, detaylar ortada kalır. Ana kayıt olmadığına göre detaylara da ihtiyaç yoktur. Bu nedenle ana kayıt silinmeden önce detayları silmek gerekir. Table1 ana tabloya, Table2 de Detay tabloya bağlı kabul edilirse, Table1' den bir kayıt silinmek istendiğinde önce Table2' deki detaylar temizlenecektir aşağıdaki örnek bunu göstermektedir.
procedure TForm1.Table1BeforeDelete(DataSet: TDataset)
begin
with Table2 do begin
DisableControls;
First;
While not EOF do
Delete;
EnableControls;
end;
end;
DBGrid ve Memo alanlar
DBGrid bileşeninde Memo/Blob alanlar <memo> olarak gösterilir.
Aşağıdaki örnekte bu tür alanların da metin olarak görüntülenmesi sağlanmaktadır. Table bileşeni üzerine yüklenen kolonlardan NOTES alanı MEMO tipindedir. Bu alanın GetText yordamında Blob2Str fonksiyonu kullanılarak, alandaki veri görünür hale getirilmektedir.
procedure TForm1.Table1NotesGetText(Sender: TField; var Text: String;
DisplayText: Boolean);
begin
Text := Blob2Str(TMemoField(Sender));
end;
Blob2Str fonksiyonu:
function Blob2Str(TheField : TMemoField): String;
var
Buffer: PChar;
MemSize: Integer;
tmp:string;
begin
if TheField.IsNull then
Result := '' else
with TBlobStream.Create(TheField, bmRead) do
begin
MemSize := Size;
Inc(MemSize); Buffer := AllocMem(MemSize);
Read(Buffer^, memsize);
Free;
end;
result:=strpas(buffer);
end;
Tablo içeriğinin TstrinGrid bileşenine doldurulması
Tablo içeriğinin TstrinGrid bileşenine doldurulması şu şekilde olur.
table.first;
row := 0;
grid.rowcount := table.recordCount;
while not table.eof do begin
for i := 0 to table.fieldCount-1 do
grid.cells[i,row] := table.fields[i].asString;
inc (row);
table.next;
end;
TTable veya TQuery üzerinden kayıt numarasının bulunması
Dataset Paradox veya dBASE tablosuna bağlı ise kayıt numarasını bulmak, birkaç BDE fonksiyon kullanmak suretiyle mümkündür. Ancak SQL tabanlı veri tabanı sunumcularında, sunumcunun kendisi buna imkan vermiyorsa, bu bilgi elde edilemez.
Aşağıdaki fonksiyon parametre olarak bir Ttable bileşeni almakta ve gösterdiği Paradox/dBase tablosunudan kayıt numarasını, başarısız olduğunda ise 0 değerini döndürmektedir.
Bu fonksiyonun döndürdüğü kayıt numarası, kaydın tablodaki fiziksel yeri ile ilgilidir. Indeks tanımlanmış bir TTable veya "Order by" ile sıraya sokulmuş bir sorgu kümesi döndüren Tquery bileşeninde, hatalı değer döndüğü sanısına kapılınmamalıdır.
uses
DbiProcs, DbiTypes, DBConsts;
function Form1.Recno( oTable: TTable ): Longint;
var
rError: DBIResult;
rRecProp: RECprops;
szErrMsg: DBIMSG;
begin
Result := 0;
try
oTable.UpdateCursorPos;
rError := DbiGetRecord( oTable.Handle, dbiNOLOCK, nil, @rRecProp );
if rError = DBIERR_NONE then
Result := rRecProp.iPhyRecNum
else
case rError of
DBIERR_BOF: Result := 1;
DBIERR_EOF: Result := oTable.RecordCount + 1;
else
begin
DbiGetErrorString( rError, szErrMsg );
ShowMessage( StrPas( szErrMsg ));
end;
end;
except
on E: EDBEngineError do ShowMessage( E.Message );
end;
end;
Şekil 3 : Form1
kod örneği 5 : form1.dfm
object Form1: TForm1
Left = 200
Top = 108
Width = 451
Height = 250
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 112
Top = 16
Width = 32
Height = 13
Caption = 'Label1'
end
object Label2: TLabel
Left = 32
Top = 16
Width = 49
Height = 13
Caption = 'Kayıt No : '
end
object DBGrid1: TDBGrid
Left = 16
Top = 32
Width = 417
Height = 120
DataSource = DataSource1
TabOrder = 0
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'MS Sans Serif'
TitleFont.Style = []
end
object DBNavigator1: TDBNavigator
Left = 192
Top = 168
Width = 240
Height = 25
DataSource = DataSource1
TabOrder = 1
end
object DataSource1: TDataSource
DataSet = Table1
Left = 88
Top = 168
end
object Table1: TTable
Active = True
AfterScroll = Table1AfterScroll
DatabaseName = 'dbdemos'
TableName = 'ANIMALS.DBF'
Left = 16
Top = 168
end
end
kod örneği 6 : unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, ExtCtrls, DBCtrls, Grids, DBGrids, Db, DBTables;
type
TForm1 = class(TForm)
DataSource1: TDataSource;
DBGrid1: TDBGrid;
DBNavigator1: TDBNavigator;
Label1: TLabel;
Label2: TLabel;
Table1: TTable;
function Recno( oTable: Ttable): Longint;
procedure Table1AfterScroll(DataSet: TDataSet);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
DbiProcs, DbiTypes, DBConsts;
{$R *.DFM}
function TForm1.Recno( oTable: Ttable): Longint;
var
rError: DBIResult;
rRecProp: RECprops;
szErrMsg: DBIMSG;
begin
Result := 0;
try
oTable.UpdateCursorPos;
rError := DbiGetRecord( oTable.Handle, dbiNOLOCK, nil, @rRecProp );
if rError = DBIERR_NONE then
Result := rRecProp.iPhyRecNum
else
case rError of
DBIERR_BOF: Result := 1;
DBIERR_EOF: Result := oTable.RecordCount + 1;
else
begin
DbiGetErrorString( rError, szErrMsg );
ShowMessage( StrPas( szErrMsg ));
end;
end;
except
on E: EDBEngineError do ShowMessage( E.Message );
end;
end;
procedure TForm1.Table1AfterScroll(DataSet: TDataSet);
begin
label1.caption:=inttostr(recno(table1));
end;
end.
dBase tablolarından silinmiş kayıtların atılması
Bu işlem için DbiPackTable. İsimli BDE fonksiyonu kullanılır.
Örnek kod şu şekildedir.
uses
DbiProcs, DbiTypes, DBConsts;
procedure TForm1.Button1Click(Sender: TObject);
var
Error: DbiResult;
ErrorMsg: String;
Special: DBIMSG;
begin
table1.Active := False;
try
Table1.Exclusive := True;
Table1.Active := True;
Error := DbiPackTable(Table1.DBHandle, Table1.Handle, nil, szdBASE, True);
Table1.Active := False;
Table1.Exclusive := False;
finally
Table1.Active := True;
end;
case Error of
DBIERR_NONE:
ErrorMsg := 'Tamam';
DBIERR_INVALIDPARAM:
ErrorMsg := 'Tablo belirsiz' +
'name is NULL';
DBIERR_INVALIDHNDL:
ErrorMsg := 'Veri tabanı belirsiz';
DBIERR_NOSUCHTABLE:
ErrorMsg := 'Tablo adı belirsiz';
DBIERR_UNKNOWNTBLTYPE:
ErrorMsg := 'Tablo tipi belirsiz';
DBIERR_NEEDEXCLACCESS:
ErrorMsg := 'Tablo exclusive modda değil';
else
DbiGetErrorString(Error, Special);
ErrorMsg := '[' + IntToStr(Error) + ']: ' + Special;
end;
MessageDlg(ErrorMsg, mtWarning, [mbOk], 0);
end;
Uygulama içerisinden BDE Kod Adı (Alias) yaratılması
procedure createalias(aliasname, servername, servertype, filename:string);
var
List: TStringList;
lang,
user,
pdox : string;
begin
lang:='ANTURK';
user:='SYSDBA';
pdox:='PARADOX';
List := TStringList.Create;
with List do
begin
Clear;
if servertype='INTRBASE' then
begin
Add(Format('SERVER NAME=%s',[filename]));
Add(Format('LANGDRIVER=%s',[lang]));
Add(Format('USER NAME=%s',[user]));
end;
if servertype='STANDART' then
begin
Add(Format('DEFAULT DRIVER=%s',[pdox]));
Add(Format('PATH=%s',[filename]));
end;
end;
if session.isalias(aliasname) then
Session.ModifyAlias(aliasname, List)
else
Session.addAlias(aliasname,servertype, List);
Session.SaveConfigFile;
List.Free;
end;
BDE Koad adı (alias) parametrelerinin elde edilmesi
Session.GetAliasParams('DBDEMOS',listbox1.items);
Bir dBase (.DBF) tablosundaki silinmiş kayıtların görüntülenmesi
dBase tablolarındaki silinmiş kayıtların görünür hale getirilmesi için DbiSetProp fonksiyonu kullanılır.
procedure SetDelete(oTable:TTable; Value: Boolean);
var
rslt: DBIResult;
szErrMsg: DBIMSG;
begin
try
oTable.DisableControls;
try
rslt := DbiSetProp(hDBIObj(oTable.Handle), curSOFTDELETEON,
LongInt(Value));
if rslt <> DBIERR_NONE then
begin
DbiGetErrorString(rslt, szErrMsg);
raise Exception.Create(StrPas(szErrMsg));
end;
except
on E: EDBEngineError do ShowMessage(E.Message);
on E: Exception do ShowMessage(E.Message);
end;
finally
oTable.Refresh;
oTable.EnableControls;
end;
end;
Şekil 4 : Örnek uygulama form yapısı
kod örneği 7: Form1.dfm
object Form1: TForm1
Left = 200
Top = 108
Width = 559
Height = 293
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 96
TextHeight = 13
object DBGrid1: TDBGrid
Left = 8
Top = 8
Width = 409
Height = 177
DataSource = DataSource1
TabOrder = 0
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'MS Sans Serif'
TitleFont.Style = []
end
object DBNavigator1: TDBNavigator
Left = 8
Top = 200
Width = 240
Height = 25
DataSource = DataSource1
TabOrder = 1
end
object Button1: TButton
Left = 432
Top = 8
Width = 113
Height = 25
Caption = 'Silinenleri göster'
TabOrder = 2
OnClick = Button1Click
end
object Button2: TButton
Left = 432
Top = 40
Width = 113
Height = 25
Caption = 'Silinenleri sakla'
TabOrder = 3
OnClick = Button2Click
end
object Table1: TTable
Active = True
DatabaseName = 'dbdemos'
TableName = 'ANIMALS.DBF'
Left = 440
Top = 80
end
object DataSource1: TDataSource
DataSet = Table1
Left = 488
Top = 80
end
end
kod örneği 8 : unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, DBCtrls, Grids, DBGrids, Db, DBTables;
type
TForm1 = class(TForm)
Table1: TTable;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
DBNavigator1: TDBNavigator;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
DbiProcs, DbiTypes, DBConsts;
{$R *.DFM}
procedure SetDelete(oTable:TTable; Value: Boolean);
var
rslt: DBIResult;
szErrMsg: DBIMSG;
begin
try
oTable.DisableControls;
try
rslt := DbiSetProp(hDBIObj(oTable.Handle), curSOFTDELETEON,
LongInt(Value));
if rslt <> DBIERR_NONE then
begin
DbiGetErrorString(rslt, szErrMsg);
raise Exception.Create(StrPas(szErrMsg));
end;
except
on E: EDBEngineError do ShowMessage(E.Message);
on E: Exception do ShowMessage(E.Message);
end;
finally
oTable.Refresh;
oTable.EnableControls;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SetDelete(Table1, TRUE);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
SetDelete(Table1, False);
end;
end.
Bir tablodaki alan sayısının bulunması
Ttable bileşenini kullanarak, bir tablodaki alan sayısının bulunması için
TableX.fieldcount
Özelliğinden faydalanılabilir. Ancak tablo alanlarının bir kısmı, ttable bileşeni üzerine yüklenmişse fieldcount özelliği sadece yüklenen alan sayısını getirir. Alanları ttable üzerine kısmen yüklenmiş olan bir tablonun, gerçek alan sayısının bulunabilmesi için, aşağıdaki fonksiyon kullanılabilir.
Bu kodun kullanılabilmesi için, form üzerine yerleştirileni ttable bileşenine, bağlandığı tablo alanlarının bir kısmı yüklenmelidir.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Db, DBTables,
DbiErrs, DbiTypes, DbiProcs ,bde;
type
TForm1 = class(TForm)
{
Alanlar yüklendiğinde, tanımları buraya yerleşecektir.
}
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function GetFieldCount(T: TTable): Integer;
var
curProp: CURProps;
bWasOpen: Boolean;
begin
Result := 0; {Just in case something goes wrong.}
bWasOpen := T.Active;
try
if not bWasOpen then
T.Open;
Check(DbiGetCursorProps(T.Handle, curProp));
Result := curProp.iFields;
finally
if not bWasOpen then
T.Close;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
showmessage(inttostr(table1.fieldcount));
showmessage(inttostr(GetFieldCount(table1)));
end;
end.
Bir tablodaki verinin, başka bir tabloya eklenmesi
Aynı yapıdaki iki ayrı toblo muhteviyatının, birleştirilmesi için kullanılabilecek olan bu fonksiyon, <SourceTable> isimli tablodaki verileri, <DestinationTable> isimli tabloya kopyalamaktadır. Bu yöntemle veriler, farklı veri tabanları arasında da taşınabilir.
Function AddTables(
const
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestinationTable: string): Boolean;
Var
BMode : TBatchMode;
Begin
If IsTableKeyed(DestDatabaseName,DestinationTable) Then
Begin
If IsTableKeyed(SourceDatabaseName,SourceTable) Then
Begin
BMode := BatAppendUpdate;
End
Else
Begin
BMode := BatAppend;
End;
End
Else
Begin
BMode := BatAppend;
End;
Result := DBRecordMove(SourceDatabaseName,SourceTable,
DestDatabaseName,DestinationTable,BMode);
End;
Sorgudan tablo yaratılması
Karmaşık sorgular sonucunda toplanan veriler, bu fonksiyon yardımıyla yaratılan bir tablo içerisine doldurulabilir.
Function DBCreateTableFromQuery(
Query: TQuery;
NewTableName,
TableDatabaseName: String): Boolean;
var
D : TTable;
ActiveWas : Boolean;
begin
D := nil;
try
{The Source Table}
ActiveWas := Query.Active;
Query.Active := true;
D := TTable.Create(nil);
D.Active := False;
D.DatabaseName := TableDatabaseName;
D.TableName := NewTableName;
D.ReadOnly := False;
D.BatchMove(Query,batCopy);
Query.Active := ActiveWas;
Result := True;
finally
D.Free;
end;
End;
Sorgudan tabloya veri aktarımı
Bir sorgu neticesinde elde edilen veriler, bu fonksiyon kullanılarak, mevcut bir tabloya aktarılabilir.
Procedure DBAddQueryToTable(
DataSet : TQuery;
const
DestDatabaseName,
DestinationTable: string);
var
DTable : TTable;
BMove : TBatchMove;
begin
DTable := TTable.Create(nil);
BMove := TBatchMove.Create(nil);
Try
DataSet.Active := True;
DTable.DatabaseName := DestDatabaseName;
DTable.TableName := DestinationTable;
DTable.Active := True;
BMove.AbortOnKeyViol := False;
BMove.AbortOnProblem := False;
BMove.ChangedTableName := 'CTable';
BMove.Destination := DTable;
BMove.KeyViolTableName := 'KTable';
BMove.Mode := batAppend;
BMove.ProblemTableName := 'PTable';
BMove.Source := DataSet;
BMove.Execute;
Finally
DTable.Active := False;
DTable.Free;
BMove.Free;
End;
End;
Tablodaki bir alana ait verilerin, başka bir alana kopyalanması
Bir tabloda bulunan alanlardan bir içerisinde bulunan veriler, başka bir alana kopyalanacağı zaman, aşağıdaki fonksiyon kullanılabilir.
function DBCopyFieldAToB(
DatabaseName,
TableName,
SourceField,
DestField: String): Boolean;
var
Query : TQuery;
CursorWas : TCursor;
Sess : TSession;
begin
CursorWas := Screen.Cursor;
Sess := DBSessionCreateNew;
Sess.Active := True;
Query := TQuery.Create(sess);
Query.SessionName := Sess.SessionName;
Sess.Active := True;
Query.Active := False;
Query.RequestLive := True;
try
Result := False;
Query.DatabaseName := DatabaseName;
Query.SQL.Clear;
Query.SQL.Add('Select ');
Query.SQL.Add(SourceField+',');
Query.SQL.Add(DestField);
Query.SQL.Add('From '+TableName);
Query.Open;
Query.First;
While Not Query.EOF Do
Begin
ProgressScreenCursor;
Try
Query.Edit;
Query.FieldByName(DestField).AsString :=
Query.FieldByName(SourceField).AsString;
Query.Post;
Except
End;
Query.Next;
End;
Result := True;
finally
Query.Free;
Screen.Cursor := CursorWas;
Sess.Active := False;
end;
end;
Tablo kopyalama
Bir tablo olduğu gibi , başka bir veri tabanına veya aynı veri tabanına kopyalanabilir. <DestTable> isimli bir tablo mevcutsa, eskisi silinir.. Bu fonksiyon oldukça güçlü bir veri taşıma aracıdır. Tablolar, BDE tarafından desteklenen, herhangi bir veri tabanı ortamından, başka bir veri tabanı ortamına kopyalanabilir. Aşağıdaki örnekte, "DBDemos" veri tabanındaki "Customer.db" isimli tablo, "Sybase" veri tabanına kopyalanmaktadır.,
Tablo yapısı, <SourceTable> tablosundan alınmak suretiyle, karşı tarafta yeni bir tablo yaratılmaktadır. Tarafların, lokalde veya uzakta olmaları farketmez. Eğer karşı tarafta aynı adı taşıyan bir tablo varsa, silinir ve yerine yenisi yaratılır.
Function DBCreateTableBorrowStr(
SourceDatabaseName : String;
SourceTableName : String;
DestDatabaseName : String;
DestTableName : String): Boolean;
Var
S : TTable;
D : TTable;
i,j : Integer;
IMax : Integer;
IndexName : String;
IndexFields : String;
IndexFields2 : String;
Q : TQuery;
IDXO : TIndexOptions;
Begin
S := TTable.Create(nil);
D := TTable.Create(nil);
Try
Try
S.Active := False;
S.DatabaseName := SourceDatabaseName;
S.TableName := SourceTableName;
S.TableType := ttDefault;
S.Active := True;
D.DatabaseName := DestDatabaseName;
D.TableName := DestTableName;
D.TableType := ttDefault;
D.FieldDefs.Assign(S.FieldDefs);
D.CreateTable;
{Similar method could be used to create the indices}
{D.IndexDefs.Assign(S.IndexDefs);}
S.IndexDefs.Update;
D.IndexDefs.Update;
D.IndexDefs.Clear;
D.IndexDefs.Update;
For i := 0 To S.IndexDefs.Count - 1 Do
Begin
If Pos('.DB',UpperCase(DestTableName)) > 0 Then
Begin
{Paradox or DBase Tables}
If S.IndexDefs.Items[i].Name = '' Then
Begin
If Pos('.DB',UpperCase(DestTableName)) = 0 Then
Begin
IndexName := DestTableName+IntToStr(i);
End
Else
Begin
IndexName := '';
End;
End
Else
Begin
IndexName := DestTableName+IntToStr(i);
End;
IndexFields := S.IndexDefs.Items[i].Fields;
D.AddIndex(IndexName,IndexFields,
S.IndexDefs.Items[i].Options);
D.IndexDefs.Update;
End
Else
Begin
{Non Local Tables}
Q := TQuery.Create(nil);
Try
S.IndexDefs.Update;
D.IndexDefs.Update;
D.IndexDefs.Clear;
D.IndexDefs.Update;
IMax := S.IndexDefs.Count - 1;
For j := 0 To IMax Do
Begin
Q. Active := False;
Q.DatabaseName := DestDatabaseName;
IndexName := DestTableName+IntToStr(i);
IndexFields := S.IndexDefs.Items[i].Fields;
IndexFields2 :=
ReplaceCharInString(IndexFields,';',',');
Q.SQL.Clear;
Q.SQL.Add('Create');
If ixUnique in S. IndexDefs.Items[j].Options
Then Begin
Q.SQL.Add('Unique');
End;
If ixDescending in S.IndexDefs.Items[j].Options
Then Begin
Q.SQL.Add('Desc');
End
Else
Begin
Q.SQL.Add('Asc');
End;
Q.SQL.Add('Index');
Q.SQL.Add(IndexName);
Q.SQL.Add('On');
Q.SQL.Add(DestTableName);
Q.SQL.Add('(');
Q.SQL.Add(IndexFields2);
Q.SQL.Add(')');
Try
Q.ExecSql;
D.IndexDefs.Update;
D.AddIndex(IndexName,IndexFields,
S.IndexDefs.Items[j].Options);
D.IndexDefs.Update;
Except
On E : EDBEngineError Do
Begin
If E.Message = 'Invalid array of index
descriptors.'
Then Begin
Try
D.IndexDefs.Update;
D.DeleteIndex(IndexName);
D.IndexDefs.Update;
Except
End;
End
Else
Begin
Try
D.IndexDefs.Update;
IDXO := D.IndexDefs.Items[j].Options;
Except
End;
End;
End;
End;
End;
//i:= IMax;
Finally
Q.Free;
End;
End;
End;
S.Active := False;
Result := True;
Finally
S.Free;
D.Free;
End;
Except
On E : Exception Do
Begin
ShowMessage('DBCreateTableBorrowStr Error: '+E.Message);
Result := False;
End;
End;
End;
Tablo silme
Herhangi bir veri tabanından tablo silmek gerektiğinde, aşağıdaki fonksiyon kullanılabilir.
Function DBDropTable(const DatabaseName, TableName : string):Boolean;
var Query : TQuery;
begin
Result := False;
If Not IsTable(DatabaseName, TableName) Then
Begin
Exit;
End;
Query := TQuery.Create(nil);
try
Query.DatabaseName := DatabaseName;
Query.SQL.Clear;
Query.SQL.Add('Drop Table ');
If (Pos('.DB', UpperCase(TableName)) > 0) Or
(Pos('.DBF',UpperCase(TableName)) > 0) Then
Begin
Query.Sql.Add('"'+TableName+'"');
End
Else
Begin
Query.Sql.Add(TableName);
End;
Result := True;
Try
Query.ExecSQL;
Except
Result := False;
End;
finally
Query.Free;
end;
end;
Alan adının bulunması
Sıra numarası verilen bir tablo alanının alan adı bu fonksiyonla alınabilir.
Function DBFieldNameByNo(
DatabaseName : String;
TableName : String;
FieldNo : Integer): String;
Var
Table : TTable;
Begin
Result := '';
If Not IsTable(DatabaseName, TableName) Then Exit;
If FieldNo < 0 Then Exit;
If FieldNo >= DBNFields(DatabaseName, TableName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
Result := Table.FieldDefs[FieldNo].Name;
Except
End;
Finally
Table.Free;
End;
End;
Ortak alan isimleri
Bu fonksiyonda, her iki tabloda da mevcut olan alan isimleri, aralarına konan virgüllerle ayrılmış olarak dönerler.
Function DBFieldNamesCommonToString(
DatabaseName1 : String;
TableName1 : String;
DatabaseName2 : String;
TableName2 : String): String;
Var
List1 : TStringList;
List2 : TStringList;
i : Integer;
Suffix: String;
Begin
Result := '';
List1 := TStringList.Create();
List2 := TStringList.Create();
Try
DBFieldNamesToTStrings(
DatabaseName1,
TableName1,
List1);
For i := 0 To List1.Count - 1 Do
Begin
List1[i] := UpperCase(List1[i]);
End;
DBFieldNamesToTStrings(
DatabaseName2,
TableName2,
List2);
For i := 0 To List2.Count - 1 Do
Begin
List2[i] := UpperCase(List2[i]);
End;
For i := 0 To List1.Count - 1 Do
Begin
If Result = '' Then
Begin
Suffix := '';
End
Else
Begin
Suffix := ', ';
End;
If List2.IndexOf(List1[i]) <> -1 Then
Begin
Result := Result + Suffix + List1[i];
End;
End;
Finally
List1.Free;
List2.Free;
End;
End;
Tablodaki alan isimleri
Bu fonksiyon, tablodaki alanlara ait isimleri, bir Tstrings nesnesi içerisine doldurur.
Function DBFieldNamesToTStrings(
DatabaseName : String;
TableName : String;
Strings : TStrings): Boolean;
Var
Table : TTable;
FieldNo : Integer;
Begin
Result := False;
If Not IsTable(DatabaseName, TableName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
Strings.Clear;
For FieldNo := 0 To Table.FieldDefs.Count -1 Do
Begin
Strings.Add(Table.FieldDefs[FieldNo].Name);
End;
Result := True;
Except
End;
Finally
Table.Free;
End;
End;
Alan numarası
Bu fonksiyon, adı bilinen bir alanın, tablo içerisindeki sırasını bulur.
Function DBFieldNo(DatabaseName, TableName, FieldName: String): Integer;
Var
Table : TTable;
FieldIndex : Integer;
FieldNumber: Integer;
Begin
Result := -1;
If Not IsTable(DatabaseName, TableName) Then Exit;
If Not IsField(DatabaseName, TableName, FieldName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
FieldIndex :=
Table.FieldDefs.IndexOf(FieldName);
FieldNumber :=
Table.FieldDefs[FieldIndex].FieldNo;
Result := FieldNumber;
Except
End;
Finally
Table.Free;
End;
End;
Alan uzunluğu
Tablo içerisindeki bir alanın, uzunluğu, bu fonksiyon ile bulunur.
Function DBFieldSize(DatabaseName, TableName, FieldName: String): Integer;
Var
Table : TTable;
FieldIndex : Integer;
FieldSize : Integer;
Begin
Result := 0;
If Not IsTable(DatabaseName, TableName) Then Exit;
If Not IsField(DatabaseName, TableName, FieldName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
FieldIndex :=
Table.FieldDefs.IndexOf(FieldName);
FieldSize :=
Table.FieldDefs[FieldIndex].Size;
Result := FieldSize;
Except
End;
Finally
Table.Free;
End;
End;
Alan tipleri
Adı bilinen bir alanın tipini bulmak için aşağıdaki fonksiyon kullanılabilir.
Function TypeField(DatabaseName, TableName, FieldName: String): String;
Var
Table : TTable;
FieldIndex : Integer;
FieldType : TFieldType;
Begin
Result := '';
If Not IsTable(DatabaseName, TableName) Then Exit;
If Not IsField(DatabaseName, TableName, FieldName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
FieldIndex :=
Table.FieldDefs.IndexOf(FieldName);
FieldType :=
Table.FieldDefs[FieldIndex].DataType;
If FieldType=ftUnknown Then Result := 'Unknown';
If FieldType=ftString Then Result := 'String';
If FieldType=ftSmallInt Then Result := 'SmallInt';
If FieldType=ftInteger Then Result := 'Integer';
If FieldType=ftWord Then Result := 'Word';
If FieldType=ftBoolean Then Result := 'Boolean';
If FieldType=ftFloat Then Result := 'Float';
If FieldType=ftCurrency Then Result := 'Currency';
If FieldType=ftBCD Then Result := 'BCD';
If FieldType=ftDate Then Result := 'Date';
If FieldType=ftTime Then Result := 'Time';
If FieldType=ftDateTime Then Result := 'DateTime';
If FieldType=ftBytes Then Result := 'Bytes';
If FieldType=ftVarBytes Then Result := 'VarBytes';
If FieldType=ftBlob Then Result := 'Blob';
If FieldType=ftMemo Then Result := 'Memo';
If FieldType=ftGraphic Then Result := 'Graphic';
{$IFDEF WIN32}
If FieldType=ftAutoInc Then Result := 'AutoInc';
If FieldType=ftFmtMemo Then Result := 'FmtMemo';
If FieldType=ftParadoxOle Then Result := 'ParadoxOle';
If FieldType=ftDBaseOle Then Result := 'DBaseOle';
If FieldType=ftTypedBinary Then Result := 'TypedBinary';
{$ENDIF}
Except
End;
Finally
Table.Free;
End;
End;
Yukarıdaki fonksiyon ile aynı işleve sahip bir fonksiyondur. Fakat fonksiyona alan adı değil, sıra numarası verilir.
Function DBFieldTypeByNo(DatabaseName, TableName: String; FieldNo: Integer): String;
Var
Table : TTable;
FieldIndex : Integer;
FieldType : TFieldType;
Begin
Result := '';
If Not IsTable(DatabaseName, TableName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
FieldIndex := FieldNo;
Try
FieldType :=
Table.FieldDefs[FieldIndex].DataType;
Except
FieldType := ftUnknown;
End;
{TFieldType Possible values are
ftUnknown, ftString, ftSmallint,
ftInteger, ftWord, ftBoolean,
ftFloat, ftCurrency, ftBCD, ftDate,
ftTime, ftDateTime, ftBytes, ftVarBytes,
ftBlob, ftMemo or ftGraphic}
If FieldType=ftUnknown Then Result := 'Unknown';
If FieldType=ftString Then Result := 'String';
If FieldType=ftSmallInt Then Result := 'SmallInt';
If FieldType=ftInteger Then Result := 'Integer';
If FieldType=ftWord Then Result := 'Word';
If FieldType=ftBoolean Then Result := 'Boolean';
If FieldType=ftFloat Then Result := 'Float';
If FieldType=ftCurrency Then Result := 'Currency';
If FieldType=ftBCD Then Result := 'BCD';
If FieldType=ftDate Then Result := 'Date';
If FieldType=ftTime Then Result := 'Time';
If FieldType=ftDateTime Then Result := 'DateTime';
If FieldType=ftBytes Then Result := 'Bytes';
If FieldType=ftVarBytes Then Result := 'VarBytes';
If FieldType=ftBlob Then Result := 'Blob';
If FieldType=ftMemo Then Result := 'Memo';
If FieldType=ftGraphic Then Result := 'Graphic';
Except
End;
Finally
Table.Free;
End;
End;
Tablonun anahtar alanları
Bir tabloda, anahtar olarak kullanılan alanlar, Tstrings nesnesine doldurulur.
Function DBKeyFieldNamesToTStrings(
DatabaseName : String;
TableName : String;
Strings : TStrings): Boolean;
Var
Table : TTable;
FieldNo : Integer;
Begin
Result := False;
If Not IsTable(DatabaseName, TableName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.Active := False;
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
Strings.Clear;
For FieldNo := 0 To Table.FieldDefs.Count -1 Do
Begin
If IsFieldKeyed(
DatabaseName,
TableName,
Table.FieldDefs[FieldNo].Name) Then
Begin
Strings.Add(Table.FieldDefs[FieldNo].Name);
End;
End;
Result := True;
Except
End;
Finally
Table.Free;
End;
End;
LookUp yöntemiyle değer seçme diyaloğu
Kullanıcıya bir LookUp diyaloğu gösterip, seçtiği değeri döndüren bir fonksiyondur. Eğer kullanıcı "Cancel" butonuna basarsa, boş bir karakter dizisi döner.
Function DialogLookupDetail(
Const DialogCaption : string;
Const InputPrompt : string;
Const DefaultValue : string;
Const Values : TStringList;
Const ButtonSpacing : Integer;
Const SpacerHeight : Integer;
Const TopBevelWidth : Integer;
Const PromptHeight : Integer;
Const FormHeight : Integer;
Const FormWidth : Integer;
Const Hint_OK : string;
Const Hint_Cancel : string;
Const Hint_ListBox : string;
Const ListSorted : Boolean;
Const AllowDuplicates : Boolean
): string;
Var
Form : TForm;
Base_Panel : TPanel;
Base_Buttons : TPanel;
Spacer : TPanel;
Base_Top : TPanel;
ButtonSlider : TPanel;
ButtonSpacer : TPanel;
Prompt : TPanel;
ListBox : TListBox;
ButtonCancelB: TPanel;
ButtonOKB : TPanel;
Button_Cancel: TButton;
Button_OK : TButton;
DefItemIndex : Integer;
TempValues : TStringList;
Begin
Result := DefaultValue;
Form := TForm.Create(Application);
TempValues := TStringList.Create();
Try
TempValues.Sorted := ListSorted;
TempValues.Clear;
If AllowDuplicates Then
Begin
TempValues.Duplicates := dupAccept;
End
Else
Begin
TempValues.Duplicates := dupIgnore;
End;
If Values <> nil Then
Begin
TempValues.Assign(Values);
End;
With Form Do
Begin
Try
Canvas.Font := Font;
BorderStyle := bsSizeable;
Caption := DialogCaption;
Height := FormHeight;
Width := FormWidth;
ShowHint := True;
Position := poScreenCenter;
BorderIcons := [biMaximize];
Base_Panel := TPanel.Create(Form);
With Base_Panel Do
Begin
Parent := Form;
Align := alClient;
Caption := ' ';
BorderWidth := 10;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
End;
Base_Buttons := TPanel.Create(Form);
With Base_Buttons Do
Begin
Parent := Base_Panel;
Align := alBottom;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
Height := 27;
End;
ButtonSlider := TPanel.Create(Form);
With ButtonSlider Do
Begin
Parent := Base_Buttons;
Align := alClient;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
End;
ButtonCancelB := TPanel.Create(Form);
With ButtonCancelB Do
Begin
Parent := ButtonSlider;
Align := alRight;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
Width := 75+ButtonSpacing;
End;
ButtonSpacer := TPanel.Create(Form);
With ButtonSpacer Do
Begin
Parent := ButtonCancelB;
Align := alLeft;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
Width := ButtonSpacing;
End;
ButtonOKB := TPanel.Create(Form);
With ButtonOKB Do
Begin
Parent := ButtonSlider;
Align := alRight;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
Width := 75;
End;
Spacer := TPanel.Create(Form);
With Spacer Do
Begin
Parent := Base_Panel;
Align := alBottom;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
Height := SpacerHeight;
End;
Base_Top := TPanel.Create(Form);
With Base_Top Do
Begin
Parent := Base_Panel;
Align := alClient;
Caption := ' ';
BorderWidth := 10;
BorderStyle := bsNone;
BevelOuter := bvRaised;
BevelInner := bvNone;
BevelWidth := TopBevelWidth;
End;
Prompt := TPanel.Create(Form);
With Prompt Do
Begin
Parent := Base_Top;
Align := alTop;
Caption := ' ';
BorderWidth := 0;
BorderStyle := bsNone;
BevelOuter := bvNone;
BevelInner := bvNone;
Caption := InputPrompt;
Height := PromptHeight;
Alignment := taCenter;
End;
Button_Cancel := TButton.Create(Form);
With Button_Cancel Do
Begin
Parent := ButtonCancelB;
Caption := 'Cancel';
ModalResult := mrCancel;
Default := True;
Align := alClient;
Hint := Hint_Cancel;
End;
Button_OK := TButton.Create(Form);
With Button_OK Do
Begin
Parent := ButtonOKB;
Caption := 'OK';
ModalResult := mrOK;
Default := False;
Align := alClient;
Hint := Hint_OK;
End;
ListBox := TListBox.Create(Form);
With ListBox Do
Begin
Parent := Base_Top;
Align := alClient;
Hint := Hint_ListBox;
Sorted := ListSorted;
Focused;
If TempValues <> nil Then
Begin
Items.Assign(TempValues);
DefItemIndex := Items.IndexOf(DefaultValue);
If DefItemIndex <> -1 Then
Begin
ItemIndex := DefItemIndex;
Selected[DefItemIndex];
End
Else
Begin
Result := '';
ItemIndex := 0;
Selected[0];
End;
IntegralHeight := True;
Button_OK.Default := True;
Button_Cancel.Default := False;
End
Else
Begin
Result := '';
End;
End;
SetFocusedControl(ListBox);
If ShowModal = mrOk Then
Begin
If ListBox.ItemIndex<>-1 Then
Result := ListBox.Items[ListBox.ItemIndex];
End;
Finally
Form.Free;
End;
End;
Finally
TempValues.Free;
End;
End;
Bir Paradox tablosunun yeniden anahtarlanması
Mevcut bir Paradox tablosu, aşağıdaki fonksiyon kullanılarak yeniden anahtarlanabilir.
Function DBParadoxCreateNKeys(
DatabaseName : String;
TableName : String;
NKeys : Integer): Boolean;
Var
T : TTable;
T2 : TTable;
i : Integer;
TempDBName : String;
TempTblNam : String;
TempTblStub: String;
KeysString : String;
Begin
Result := False;
{Select a temporary table name}
TempTblStub := 'qrz';
TempDBName := DatabaseName;
TempTblNam := '';
For i := 1 To 100 Do
Begin
TempTblNam := TempTblStub+StringPad(IntToStr(i),'0',3,False)+'.Db';
If Not IsTable(TempDBName,TempTblNam) Then
Begin
Break;
End
Else
Begin
If i = 100 Then
Begin
DBDeleteTable(
TempDBName,
TempTblNam);
End;
End;
End;
T := TTable.Create(nil);
T2 := TTable.Create(nil);
Try
Try
T.Active := False;
T.DatabaseName := DatabaseName;
T.TableName := TableName;
T.Active := True;
T2.Active := False;
T2.DatabaseName := TempDBName;
T2.TableName := TempTblNam;
T2.FieldDefs.Assign(T.FieldDefs);
T2.IndexDefs.Clear;
KeysString := '';
For i := 0 To NKeys - 1 Do
Begin
If i > 0 Then
Begin
KeysString := KeysString + ';';
End;
KeysString :=
KeysString +
DBFieldNameByNo(
DatabaseName,
TableName,
i);
End;
T2.IndexDefs.Add('',KeysString,[ixPrimary]);
T2.CreateTable;
T2.Active := False;
T.Active := False;
AddTables(
DatabaseName,
TableName,
TempDBName,
TempTblNam);
DBDeleteTable(DatabaseName,TableName);
T2.Active := True;
T.DatabaseName := DatabaseName;
T.TableName := TableName;
T.FieldDefs.Assign(T2.FieldDefs);
T.IndexDefs.Clear;
T.IndexDefs.Add('',KeysString,[ixPrimary]);
T.CreateTable;
T2.Active := False;
T.Active := False;
AddTables(
TempDBName,
TempTblNam,
DatabaseName,
TableName);
DBDeleteTable(
TempDBName,
TempTblNam);
Result := True;
Except
ShowMessage('Error in Function DBParadoxCreateNKeys');
End;
Finally
T.Free;
T2.Free;
End;
End;
Tablo adının değiştirilmesi
Belirtilen tablonun adını değiştirir. Bu fonksiyon kullanılırken, veri tabanındaki referans sınırlamalarına dikkat edilmelidir. SQL tabanlı veri tabanlarında, eğer tabloya referans eden başka veri tabanı nesneleri varsa, tablonun silinmesine izin verilmeyecektir.
Function DBReNameTable(
DatabaseName,
TableNameOld,
TableNameNew: String): Boolean;
Begin
Result := True;
Try
If Not IsTable(DatabaseName, TableNameOld) Then
Begin
Result := False;
Exit;
End;
{First Copy The Source Table To The New Table}
If Not DBCopyTable(
DatabaseName,
TableNameOld,
DatabaseName,
TableNameNew) Then
Begin
Result := False;
Exit;
End;
{Now Drop The Source Table}
If Not DBDropTable(DatabaseName, TableNameOld) Then
Begin
Result := False;
Exit;
End;
Except
Result := False;
End;
End;
{!~ Applies BatchMode Types As Appropriate To
Source and Destination Tables}
Function DBRecordMove(
SourceDatabaseName,
SourceTable,
DestDatabaseName,
DestTable: String;
BMode: TBatchMode): Boolean;
var S : TTable;
D : TTable;
B : TBatchMove;
begin
S := TTable.Create(nil);
D := TTable.Create(nil);
B := TBatchMove.Create(nil);
try
{Create The Source Table}
S.Active := False;
S.DatabaseName := SourceDatabaseName;
S.ReadOnly := False;
S.TableName := SourceTable;
S.Active := true;
{Create The Destination Table}
D.Active := False;
D.DatabaseName := DestDatabaseName;
D.TableName := DestTable;
D.ReadOnly := False;
{Make the table copy}
B.AbortOnKeyViol := False;
B.AbortOnProblem := False;
B.Destination := D;
B.Source := S;
B.Mode := BMode;
Try
B.Execute;
Except
End;
Result := True;
finally
S.Free;
D.Free;
B.Free;
end;
End;
Tablo yapıları aynı mı?
Bu fonksiyonda, iki tablonun yapısı karşılaştırılır ve aynı ise TRUE değeri döndürülür.
Function DBSchemaSame(const
DatabaseName1,
Table1,
DatabaseName2,
Table2: string): Boolean;
Begin
Result := IsStructureSame(DatabaseName1,Table1,DatabaseName2,Table2);
End;
{!~ Creates a new TSession object.}
{$IFDEF WIN32}
Function DBSessionCreateNew: TSession;
{$ENDIF WIN32}
{$IFDEF WIN32}
Var
List : TStringList;
Seed : String;
i : Integer;
Ses : String;
Begin
Seed := 'Session';
Ses := Seed+'0';
List := TStringList.Create;
Try
Sessions.GetSessionNames(List);
For i := 0 To 1000 Do
Begin
Ses := Seed + IntToStr(i);
If List.IndexOf(Ses) = -1 Then Break;
End;
Result := Sessions.OpenSession(Ses);
Finally
List.Free;
End;
End;
{$ENDIF}
Bir tablo alanındaki değerlerin sağ tarafındaki boşlukların temizlenmesi
Belirtilen alandaki değerlerin, sağ yanındaki boşlukları temizleyen bir fonksiyondur.
Function DBTrimBlanksRight(
DatabaseName : String;
TableName : String;
FieldName : String): Boolean;
Var
Q : TQuery;
S : String;
Begin
{ Result := False;}{zzz}
Q := TQuery.Create(nil);
Try
Q.Active := False;
Q.DatabaseName := DatabaseName;
Q.RequestLive := True;
Q.Sql.Clear;
Q.Sql.Add('Select');
Q.Sql.Add('*');
Q.Sql.Add('From');
Q.Sql.Add('"'+TableName+'"');
Q.Active := True;
Q.First;
While Not Q.EOF Do
Begin
S := Q.FieldByName(FieldName).AsString;
S := Trim(S);
S := Trim(S);
Q.Edit;
Q.FieldByName(FieldName).AsString := S;
Q.Post;
Q.Next;
End;
Result := True;
Finally
Q.Free;
End;
End;
Aranan alan, tabloda var mı?
Alan, belirtilen tabloda varsa fonksiyondan TRUE değeri döner.
Function IsField(DatabaseName, TableName, FieldName: String): Boolean;
Var
Query : TQuery;
T : TTable;
i : Integer;
UpperFN : String;
TestFN : String;
Begin
Result := False;
UpperFN := UpperCase(FieldName);
If Not IsTable(DatabaseName, TableName) Then Exit;
Query := TQuery.Create(nil);
T := TTable.Create(nil);
Try
Try
Query.DatabaseName := DatabaseName;
Query.Sql.Clear;
Query.Sql.Add('Select ');
Query.Sql.Add('a.'+FieldName+' XYZ');
Query.Sql.Add('From');
If (Pos('.DB', UpperCase(TableName)) > 0) Or
(Pos('.DBF',UpperCase(TableName)) > 0) Then
Begin
Query.Sql.Add('"'+TableName+'" a');
End
Else
Begin
Query.Sql.Add(TableName+' a');
End;
Query.Active := True;
Result := True;
Except
Try
T.Active := False;
T.DatabaseName := DatabaseName;
T.TableName := TableName;
T.Active := True;
If T.FieldDefs.IndexOf(FieldName) > -1 Then
Begin
Result := True;
End
Else
Begin
For i := 0 To T.FieldDefs.Count -1 Do
Begin
TestFN := UpperCase(T.FieldDefs[i].Name);
If TestFN = UpperFN Then
Begin
Result := True;
Break;
End;
End;
End;
T.Active := False;
Except
End;
End;
Finally
Query.Free;
T.Free;
End;
End;
Alan anahtar mı?
Belirtilen alan, o tabloda mevcutsa ve anahtar olarak kullanılıyorsa, bu fonksiyondan TRUE değeri döner.
Function IsFieldKeyed(DatabaseName, TableName, FieldName: String): Boolean;
Var
Table : TTable;
FieldIndex : Integer;
i : Integer;
KeyCount : Integer;
LocalTable : Boolean;
ParadoxTbl : Boolean;
DBaseTable : Boolean;
TempString : String;
Begin
Result := False;
If Not IsTable(DatabaseName, TableName) Then Exit;
If Not IsField(DatabaseName, TableName, FieldName) Then Exit;
TempString := UpperCase(Copy(TableName,Length(TableName)-2,3));
ParadoxTbl := (Pos('.DB',TempString) > 0);
TempString := UpperCase(Copy(TableName,Length(TableName)-3,4));
DBaseTable := (Pos('.DBF',TempString) > 0);
LocalTable := (ParadoxTbl Or DBaseTable);
Table := TTable.Create(nil);
Try
Try
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
KeyCount := Table.IndexFieldCount;
FieldIndex := Table.FieldDefs.IndexOf(FieldName);
If LocalTable Then
Begin
If ParadoxTbl Then
Begin
Result := (FieldIndex < KeyCount);
End
Else
Begin
Table.IndexDefs.UpDate;
For i := 0 To Table.IndexDefs.Count-1 Do
Begin
{Need to check if FieldName is in the Expression listing}
If Pos(UpperCase(FieldName),UpperCase(Table.IndexDefs[i].Expression))>0 Then
Begin
Result := True;
Break;
End;
{Need to check if FieldName is in the Fields listing}
If Pos(UpperCase(FieldName),UpperCase(Table.IndexDefs[i].Fields))>0 Then
Begin
Result := True;
Break;
End;
End;
End;
End
Else
Begin
If Table.
FieldDefs[FieldIndex].
Required
Then
Begin
Result := True;
End;
End;
Except
End;
Finally
Table.Free;
End;
End;
Tablo mevcut mu?
Bu fonksiyon, belirtilen tablo varsa TRUE değerini döndürür.
Function IsTable(DatabaseName, TableName: String): Boolean;
Var
Query: TQuery;
Begin
Result := False;
Query := TQuery.Create(nil);
Try
Try
Query.DatabaseName := DatabaseName;
Query.Sql.Clear;
Query.Sql.Add('Select *');
Query.Sql.Add('From');
If (Pos('.DB', UpperCase(TableName)) > 0) Or
(Pos('.DBF',UpperCase(TableName)) > 0) Then
Begin
Query.Sql.Add('"'+TableName+'"');
End
Else
Begin
Query.Sql.Add(TableName);
End;
Query.Active := True;
Result := True;
Except
End;
Finally
Query.Free;
End;
End;
Tablo mevcut ve esas anahtarı var mı
Bu fonksiyon, belirtilen tablo, mevcutsa ve öncelikli anahtara sahipsei TRUE değerini döndürür.
Function IsTableKeyed(DatabaseName, TableName: String): Boolean;
Var
Table : TTable;
i : Integer;
IsKeyed : Boolean;
Begin
Result := False;
IsKeyed := False;
If Not IsTable(DatabaseName, TableName) Then Exit;
Table := TTable.Create(nil);
Try
Try
Table.DatabaseName := DatabaseName;
Table.TableName := TableName;
Table.Active := True;
For i := 0 To Table.FieldDefs.Count-1 Do
Begin
If Table.FieldDefs[i].Required Then
Begin
IsKeyed := True;
Break;
End;
End;
If IsKeyed Then
Begin
Result := True;
End
Else
Begin
Result := False;
{Need to examine indexdefs}
If (Pos('.DB', UpperCase(TableName)) > 0) Then
Begin
{Table is either Paradox or DBase}
Table.IndexDefs.UpDate;
If (Pos('.DBF', UpperCase(TableName)) > 0) Then
Begin
{Table is a DBase Table}
If Table.IndexDefs.Count > 0 Then
Begin
Result := True;
End;
End
Else
Begin
{Table is a Paradox Table}
For i := 0 To Table.IndexDefs.Count-1 Do
Begin
If ixPrimary in Table.IndexDefs[i].Options Then
Begin
Result := True;
Break;
End;
End;
End;
End
Else
Begin
Result := False;
End;
End;
Except
End;
Finally
Table.Free;
End;
End;
Mevcut bir tablo ile aynı yapıda başka bir tablo yaratmak
Bir veri tabanı içerisinde var olan tablo ile tıpatıp aynı bir başka tablo, herhangi bir veri tabanı içerisinde yaratılabilir. "Datali" değişkenine bağlı olarak, verilerde yeni tabloya aktarılabilir.
implementation
uses DB, DBTables ;
{$R *.DFM}
function tabloaktar(SourceDB,
SourceTable,
DestDb,
DestTable:string;
datali:boolean):boolean;
var
tSource, TDest: TTable;
i:integer;
begin
TSource := TTable.create(nil);
with TSource do begin
DatabaseName := sourcedb;
TableName := Sourcetable;
open;
end;
TDest := TTable.create(nil);
with TDest do begin
DatabaseName := DestDb;
TableName := DestTable;
FieldDefs.Assign(TSource.FieldDefs);
IndexDefs.Assign(TSource.IndexDefs);
CreateTable;
end;
tdest.open;
tsource.first;
if datali then
begin
while not tsource.eof do
begin
tdest.append;
for i:=0 to tsource.fieldcount-1 do begin
tdest.fields[i].assign(tsource.fields[i]);
showmessage(tsource.fields[i].asstring)
end;
tsource.Next;
end;
end;
TSource.close;
tdest.close;
showmessage('aktarma bitti')
end;
Tablo filtreleme
Bir tablonun filterelenmesi, basit olarak filter özelliğine, seçim kriterinin yazılıp, filtered özelliğinin TRUE yapılması ile yapılır. Tablo seçim kriterine uyan kayıtları gösterir, diğerlerini göstermez.
Filtreleme işleminin, dinamik bir sorgu niteliğinde, form üzerindeki alanlar kullanılarak yapılması, daha kullanışlı olabilir. Örneğin, Oracle formlarında, sorgu moduna girildiğinde, veri alanlarının temizlenerek, sorgu parametrelerinin yazılmasına imkan vermekte ve sorgu uygula komutu ile birlikte, belirtilen kriterlere uygun sonuç kümesi getirilmektedir.
Benzer bir yapı, Delphi formlarında da kurulabilir. Bunun için takip edilecek adımlar şunlardır.
· Form üzerine,"Sorgu moduna geçiş" için kullanılacak bir buton yerleştirin.
· Butona basıldığında çalışması için, OnClick olay yordamı içerisinde verilecek
<SorgulanacakTabloAdı>.Insert
· komutu ile, veri alanlarının temizlenmesini sağlayın
· Form üzerine "Sorgu uygulama" için kullanılacak başka bir buton yerleştirip, OnClick olay yordamına,
< SorgulanacakTabloAdı >.cancel
· komutunu yazarak, arama kriteri olarak girilen değerlerin, tabloya kaydedilmemesini sağlayın. Fakat bu işlemden önce, sorgulama kriteri olarak kullanılacak alanlardaki sorgu kriterlerini değişkenlere aktararak, saklayın.
· Seçilen alanların tümü, sorgu işleminde kullanılmayabilir. Bu nedenle boş bırakılan alanların, sorgulama esnasında problem yaratmaması için, aşağıdaki fonksiyonları kullanın. Eğer, sorgulama alanı boş bırakılmışsa, bu fonksiyonlar, o alana ait her türlü değerin kabul edilmesini sağlayacaktır.
function nvlforstr(birinci:string;ikinci:string):string;
begin
if birinci=''
then result:=ikinci
else result:=birinci;
end;
function nvlforscl(birinci:string;ikinci:string):string;
begin
if birinci=' . . . '
then result:=ikinci
else result:=birinci;
end;
function nvlforTEL(birinci:string;ikinci:string):string;
begin
if birinci='( ) '
then result:=ikinci
else result:=birinci;
end;
function nvltoyil(s1 : string) : string;
begin
if length(s1)=0 then result:='*' else result:=s1;
end;
· Filtre uygulanacak tablonun OnFilter olay yordamı parametreleri arasında bulunan ACCEPT, TRUE değerini alırsa, tablodaki o kayıt, filtreleme kriterine uygun demektir. Aksi taktirde, kayıt gösterilmeyecektir. Bu yordam aşağıdaki gibi kullanılır. Bu yordamdaki kod, tablonun her satırı için çalışarak, gereken mantıksal karşılaştırmayı yapacak ve ACCEPT parametresinin değerine göre kayıt kabul veya red edilecektir.
procedure Tf_data_ana.TableFilterRecord(DataSet: TDataSet;
var Accept: Boolean);
begin
Accept := (
(Table.FieldByName('firm_adi').AsString,
nvltoyil(kurulus_adi)) and
(Table.FieldByName('firm_sah').AsString,
NVLtoyil(sahip_adi)) and
(Table.FieldByName('VER_SCL_NO').AsString = NVLForscl(ver_sic,Table.FieldByName('VER_SCL_NO').AsString)) and
(Table.FieldByName('VER_DA').AsString,
nvltoyil(vrg_d)) and
(Table.FieldByName('TEL').AsString= NVLForTEL(telefon,Table.FieldByName('TEL').AsString))
);
end;
Şifreli paradox tablosuna otomatik bağlantı
Paradox tablolarına da şifre konabilir. Bu durumda, kullanıcı bağlanırken, şifresini belirtmek zorundadır. Şifrenin uygulama tarafından otomatik olarak girilmesi için tablo açılmadan önce
Session.addpassword('<şifre>');
Komutu verilmelidir.
SubString fonksiyonunun SQL cümlesinde kullanılması
DBase ve Paradox veri tabanlarında sorgulama yapılırken kullanılabilecek bir fonksiyon olan SubString fonksiyonu, neredeyse hiç dökümante edilmemiştir. Bu fonksiyon, hem sorguda, hem sıralamada hem de karşılaştırma kısmında kullanılabilir. Notasyonu şu şekildedir.
Substring(<alan adı> from <Başlangıç> to <Bitiş>)
Örnek
Select substring(adi from 2 to 5) from customer
Where substring(adi from 4 to 5)='AL'
Order by substring(adi from 2 to 3)
DbControlGrid kaydırma çubukları
DbControlGrid bileşeninde, normalda sadece dikey kaydırma çubuğu vardır. Yatay kaydırma çubuğu görünmez. Eğer yatay kaydırma çubuğunun da görünmesi ve kullanılması istenirse yapılması gereken, ScrollBars özelliğinin yayınlanması ve seçime göre araç çubuklarının hazırlanmasıdır.
unit EDBcgrd;
interface
uses
Windows,
Messages,
SysUtils,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
DBCGrids,
Unit1 in '..\..\..\Program Files\Borland\Delphi 3\Unit1.pas' {Form1};
type scrollbartype=(sbBoth,SbNone,sbVertical,sbHorizontal);
type
TEDBCtrlGrid = class(TDBCtrlGrid)
private
{ Private declarations }
fsbars:scrollbartype;
protected
{ Protected declarations }
public
{ Public declarations }
procedure CreateWnd;override;
published
{ Published declarations }
property ScrollBars:scrollbartype read fsbars write fsbars;
end;
procedure Register;
implementation
procedure TEDBctrlgrid.CreateWnd;
begin
inherited CreateWnd;
case scrollbars of
sbboth:showscrollbar(handle,sb_both,true);
sbnone:showscrollbar(handle,sb_both,false);
sbvertical:begin
showscrollbar(handle,sb_vert,true);
showscrollbar(handle,sb_horz,false);
end;
sbhorizontal:begin
showscrollbar(handle,sb_vert,false);
showscrollbar(handle,sb_horz,true);
end;
end;
end;
procedure Register;
begin
RegisterComponents('F1Delphi', [TEDBCtrlGrid]);
end;
end.
Tablodan dosyaya aktarma
Bir Ttable bileşeninin bağlı olduğu veri tabanı tablosundaki verilerin, Sabit kolon uzunluğunda veya, kolonlar arasına ayıraçlar koymak suretiyle metin dosyasına saklanması için geliştirilmiş bir Ttable türevi bileşene ait kod aşağıdadır.
unit Exttab;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,dialogs,
Db, DBTables,StdCtrls,ComCtrls,WinTypes, WinProcs, ExtCtrls,DBCtrls;
const
LANGUAGE='TURKISH';
REGISTERED=FALSE;
type
TExtTab= class(Ttable)
private
{ Private declarations }
f_message:string;
f_about:string;
f_delimited:boolean;
f_delimeter:string;
f_filename:string;
protected
{ Protected declarations }
public
{ Public declarations }
published
procedure SaveToFile;
property IsDelimited:boolean read f_delimited write f_delimited;
property Delimeter:string read f_delimeter write f_delimeter;
property FilePathAndName:string read f_filename write f_filename;
property About:string read f_about write f_about;
{ Published declarations }
end;
implementation
var msgid:integer;
procedure TExtTab.SaveToFile;
function tamamla(instr:string;x:integer;j:integer):string;
var
l,t:integer;
begin
if (IsDelimited) and (delimeter='') then delimeter:='@';
if not isdelimited then
begin
if length(fields[j].fieldname)>=x then
x:=length(fields[j].fieldname);
for l:=1 to x-length(instr) do
instr:=instr+' ';
result:=instr+' ';
end
else result:=instr+delimeter;
end;
var
col_count:integer;
row_count:integer;
z,i,j:integer;
row:string;
f:system.text;
st,et,ft:ttime;
begin
if not active then open;
if FilePathAndName='' then
begin
filepathandname:= InputBox('Dikkat', 'Dosya ismini belirtiniz!', 'c:\TmpName.txt');
end;
col_count:=fieldcount;
row_count:=recordcount;
rewrite(f,FilePathAndName);
first;
disablecontrols;
st:=time;
for j:=0 to col_count-1 do
write(f,tamamla(fields[j].fieldname,fields[j].displaywidth,j));
writeln(f,'');
for i:=0 to row_count-1 do
begin
for j:=0 to col_count-1 do
begin
if ord(fields[j].datatype)<14 then
begin
row:=tamamla(fields[j].asstring,fields[j].displaywidth,j);
write(f,row);
end;
end;
next;
writeln(f,'');
end;
et:=time;
ft:=et-st;
showmessage('Başlangıç: '+timetostr(st)+' '+' Bitiş: '+timetostr(et)+''#10#13+
'Kayıt Sayısı: '+inttostr(fieldcount)+' Kolon X '+inttostr(recordcount)+' Satır.'#10#13+
'İşlem tamam!');
enablecontrols;
closefile(f);
end;
end.
Sorgudan dosyaya aktarma
Tquery bileşeni kullanarak yapılan sorgu neticesinde dönen sonuç kümesinin, metin dosyasına atılması için geliştirilmiş Tquery türevi bir bileşene ait kod örneği aşağıdadır. Bu örnekte, Dene ve al sürümü, bileşen uygulamasına örnek bir yöntem de yer almaktadır.
unit ExtQuery;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,Db, DBTables, WinTypes, WinProcs, ExtCtrls,DBCtrls;
const
LANGUAGE='TURKISH';
REGISTERED=FALSE;
type
TExtQuery = class(TQuery)
private
{ Private declarations }
f_message:string;
f_about:string;
f_delimited:boolean;
f_delimeter:string;
f_filename:string;
protected
{ Protected declarations }
public
{ Public declarations }
published
procedure SaveToFile;
property IsDelimited:boolean read f_delimited write f_delimited;
property Delimeter:string read f_delimeter write f_delimeter;
property FilePathAndName:string read f_filename write f_filename;
property About:string read f_about write f_about;
constructor create(aowner:tcomponent);override;
destructor destroy;override;
{ Published declarations }
end;
implementation
var
msgid:integer;
constructor TExtquery.create(aowner:tcomponent);
begin
inherited;
about:='Written by Faruk DEMİREL (fdemirel@kkk.tsk.mil.tr) 01.02.1998 Turkey';
if (not registered) AND (componentstate <> [csDesigning]) then
{Eğer kayıtlı bir kullanıcı değilse ve uygulama çalışma modunda ise, uyarı ve tanıtım mesajını ver.}
if language='ENGLISH' then
begin
showmessage ('EXTENDED QUERY'+#10#13+
'TRIAL'+#10#13+
'BY FARUK DEMİREL'+#10#13+
'fdemirel@kkk.tsk.mil.tr');
msgid:=300;
end
else
begin
showmessage ('EXTENDED QUERY'+#10#13+
'DENE VE AL SÜRÜMÜ'+#10#13+
'YAZAN FARUK DEMİREL'+#10#13+
'fdemirel@kkk.tsk.mil.tr');
msgid:=100;
end;
end;
destructor TExtquery.destroy;
begin
inherited;
end;
procedure TExtQuery.SaveToFile;
function tamamla(instr:string;x:integer):string;
var
l,t:integer;
begin
if (IsDelimited) and (delimeter='') then delimeter:='@';
if FilePathAndName='' then
begin
showmessage('Invalid path or filename');
exit;
end;
if not isdelimited then
begin
if length(instr)<x then
for l:=1 to x-length(instr) do
instr:=instr+' ';
result:=instr+' ';
end
else result:=instr+delimeter;
end;
var
col_count:integer;
row_count:integer;
z,i,j:integer;
w:array[0..49] of string;
row:string;
f:system.text;
begin
if not active then open;
col_count:=fieldcount;
row_count:=recordcount;
rewrite(f,FilePathAndName);
first;
for j:=0 to col_count-1 do
write(f,tamamla(fields[j].fieldname,fields[j].displaywidth));
writeln(f,'');
for i:=0 to row_count-1 do
begin
for j:=0 to col_count-1 do
begin
if ord(fields[j].datatype)<14 then
begin
row:=tamamla(fields[j].asstring,fields[j].displaywidth);
write(f,row);
end;
end;
next;
writeln(f,'');
end;
closefile(f);
end;
end.
Özel bir DBGrid
Tarih alanlarına veri girişi herzaman problemdir. Bilgisayarların tarih formatları farklı olabileceği gibi, kullanıcıların tarih kullanma alışkanlıklarındaki farklılıklar da, veri tabanına tarih girişi işlemlerinde, hata mesajlarına sebep olur.
Aşağıdaki bileşen, DBGrid bileşeninden türetilmiş olup, Tarih alanına çift tıklandığında, otomatik olarak açılan bir takvimden seçim yapmak suretiyle bilgi girişini sağlamaktadır.
unit ExtDbGrid;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,Db, DBTables,buttons, StdCtrls, DBGrids,ComCtrls, WinTypes,
WinProcs, ExtCtrls, Menus, Calendar,DBCtrls;
const
Tdatefieldtype=9;
type
TExtDbGrd = class(TDBGrid)
private
{ Private declarations }
f_message:string;
f_about:string;
protected
{ Protected declarations }
public
{ Public declarations }
published
property About:string read f_about write f_about;
procedure DblClick;override;
procedure Takvimyap;
procedure Takvimkapat;
procedure mybtnclick(sender:tobject);
constructor create(aowner:tcomponent);override;
destructor destroy;override;
{ Published declarations }
end;
implementation
{$R *.RES}
var
takvimform:tform;
takvimpanel:tpanel;
takvim:tcalendar;
takvimbtn:array [1..6] of tspeedbutton;
takvimedit:tedit;
msgid:integer;
oneinstance:boolean;
constructor TExtDbGrd.create(aowner:tcomponent);
begin
inherited;
color:=clyellow;
font.color:=clblue;
about:='Written by Faruk DEMİREL (fdemirel@kkk.tsk.mil.tr) 01.02.1998 Turkey';
end;
destructor TExtdbgrd.destroy;
begin
inherited;
end;
procedure TExtDbGrd.dblclick;
begin
inherited;
if not oneinstance then
begin
if ord(fields[selectedindex].datatype)=11 then
SHOWMESSAGE('TarihSaat tipindeki alanlarda takvim açılmaz');
if (ord(fields[selectedindex].datatype)=TdateFieldType) then
begin
oneinstance:=true;
takvimyap;
takvim.calendardate:=strtodate(fields[selectedindex].asstring);
end;
end;
end;
procedure TEXTDBGRD.Takvimyap;
var
i:integer;
begin
takvimform:=tform.create(self);
takvimform.width:=267;
takvimform.height:=195;
takvimform.borderstyle:=bstoolwindow;
takvimform.formstyle:=fsstayontop;
takvimform.visible:=false;
takvimform.BORDERICONS:=[];
{takvim paneli}
takvimpanel:=tpanel.create(self);
takvimpanel.width:=250;
takvimpanel.height:=160;
takvimpanel.parent:=takvimform;
takvimpanel.left:=5 ;
takvimpanel.top:=5;
{takvim}
takvim:=tcalendar.create(takvimpanel);
takvim.parent:=takvimpanel;
takvim.left:=10;
takvim.top:=10;
takvim.width:=200;
takvim.color:=color;
takvim.font.color:=font.color;
{takvim butonları}
for i:=1 to 6 do
begin
takvimbtn[i]:=tspeedbutton.create(self);
takvimbtn[i].parent:=takvimpanel;
takvimbtn[i].left:=215;
takvimbtn[i].width:=25;
takvimbtn[i].height:=22;
takvimbtn[i].top:=10+25*(i-1);
takvimbtn[i].onclick:=mybtnclick;
takvimbtn[i].tag:=i;
takvimbtn[i].showhint:=true;
end;
takvimbtn[1].GLYPH.Handle := LoadBitmap(HInstance,'PY');
takvimbtn[1].hint:='Önceki Yıl';
takvimbtn[2].GLYPH.Handle := LoadBitmap(HInstance,'PM');
takvimbtn[2].hint:='Önceki Ay';
takvimbtn[3].GLYPH.Handle := LoadBitmap(HInstance,'NM');
takvimbtn[3].hint:='Sonraki Ay';
takvimbtn[4].GLYPH.Handle := LoadBitmap(HInstance,'NY');
takvimbtn[4].hint:='Sonraki Yıl';
takvimbtn[5].GLYPH.Handle := LoadBitmap(HInstance,'CHOOSE');
takvimbtn[5].hint:='Seç';
takvimbtn[6].GLYPH.Handle := LoadBitmap(HInstance,'QUIT');
takvimbtn[6].hint:='Çık';
{takvim editi}
takvimedit:=tedit.create(self);
takvimedit.parent:=takvimpanel;
takvimedit.left:=75 ;
takvimedit.top:=130;
takvimedit.width:=70;
takvimedit.text:=datetostr(takvim.calendardate);
takvimedit.readonly:=true;
takvimform.formstyle:=fsstayontop;
takvimform.visible:=true;
takvimform.show;
end;
procedure TExtDbGrd.Takvimkapat;
var
i:integer;
begin
for i:=1 to 5 do takvimbtn[i].free;
takvim.free;
takvimedit.free;
takvimpanel.free;
takvimform.visible:=false;
takvimform.Free;
oneinstance:=false;
end;
procedure TExtDbGrd.mybtnclick(sender:tobject);
begin
case (sender as tspeedbutton).tag of
1:{- yıl}begin
takvim.prevyear;
takvimedit.text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarDate);
end;
2:{- ay}begin
takvim.prevmonth;
takvimedit.text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarDate);
end;
3:{+ yıl}begin
takvim.nextmonth;
takvimedit.text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarDate);
end;
4:{+ ay} begin
takvim.nextyear;
takvimedit.text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarDate);
end;
5:{kapat}begin
datasource.dataset.edit;
text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarDate);
fields[selectedindex].value:=text;
datasource.dataset.post
end;
6:{İptal}begin
takvimkapat;
end;
end;
end;
initialization
oneinstance:=false;
end.
DBNavigator butonlarına erişim
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, DBCtrls, DBNavigator1;
type
TForm1 = class(TForm)
DBNavigator1: TDBNavigator;
Button1: TButton;
DBNavigator11: TDBNavigator1;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
DBNavigator11.setbuttonenabled(nbfirst);
end;
end.
2. Ağ işlemleri
Bu bölümde, Delphi uygulamalarında gerekebilecek, ağ uygulamaları ve ağ erişimleri ile ilgili püf noktaları ve kod örnekleri yer almaktadır.
Ağ sürücüleri
Sistemde tanımlı olan ağ sürücülerinin listesini elde etmek için aşağıdaki fonksiyon kullanılabilir.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function GetNetworkDriveMappings(
sl : TStrings ) : integer;
var
i : integer;
sNetPath : string;
dwMaxNetPathLen : DWord;
begin
sl.Clear;
dwMaxNetPathLen := MAX_PATH;
SetLength( sNetPath,
dwMaxNetPathLen );
for i := 0 to 25 do
begin
if( NO_ERROR =
Windows.WNetGetConnection(
PChar(
'' + Chr( 65 + i ) + ':' ),
PChar( sNetPath ),
dwMaxNetPathLen ) )then
begin
sl.Add( Chr( 65 + i ) + ': ' +
sNetPath );
end;
end;
Result := sl.Count;
end;
procedure TForm1.Button1Click(Sender: TObject);
//
// here's how to call GetNetworkDriveMappings():
//
var
sl : TStrings;
nMappingsCount,
i : integer;
begin
sl := TStringList.Create;
nMappingsCount :=
GetNetworkDriveMappings( sl );
for i := 0 to nMappingsCount-1 do
begin
//
//İstenen şeyler burada yapılabilir.
// Şimdilik sadece görüntülensin
//
MessageBox( 0,
PChar( sl.Strings[ i ] ),
'Tanımlı Ağ diskleri',MB_OK );
end;
listbox1.items.assign(sl);
sl.Free;
end;
end.
Ağ da tanımlı kullanıcılar kimler?
Ağ ortamındayken, aynı ağa giriş yapmaya yetkili kullanıcıların (bilgisayarların), isimlerini bulup getiren bir bileşene ait unit aşağıdadır.
Kullanılabilmesi için, sisteme bileşen olarak tanımlanması gereklidir. Bunun için, Components | Install components menüsü kullanılır.
unit NetUsers;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TNetUsers = class(TComponent)
private
{ Private declarations }
fServer : String;
protected
{ Protected declarations }
Procedure SetServer(Server : String);
public
{ Public declarations }
UserList: TStringList;
Constructor Create(Owner:TComponent); override;
Destructor Destroy; override;
Function Execute : Boolean;
published
{ Published declarations }
property Server :String read fServer write SetServer;
end;
PnetResourceArr = ^TNetResource;
procedure Register;
implementation
Procedure TNetUsers.SetServer(Server : String);
Begin
If fServer <> Server Then
fServer := Server;
End;
Constructor TNetUsers.Create(Owner:TComponent);
Begin
Inherited Create(Owner);
If Not ( csDesigning in ComponentState ) Then
Begin
UserList := TStringList.Create;
UserList.Sorted := True;
End;
End;
Destructor TNetUsers.Destroy;
Begin
If Not( csDesigning in ComponentState ) Then
UserList.Destroy;
Inherited Destroy;
End;
Function TNetUsers.Execute : Boolean;
Var
NetResource: TNetResource;
Buf:Pointer;
Count, BufSize, Res: DWORD;
i : Integer;
lphEnum: THandle;
p : PnetResourceArr;
Begin
Execute := False;
UserList.Clear;
GetMem(Buf, 8192);
Try
FillChar(NetResource, SizeOf(NetResource), 0);
NetResource.lpRemoteName := PChar(fServer);
NetResource.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;
NetResource.dwUsage := RESOURCEUSAGE_CONTAINER;
NetResource.dwScope := RESOURCETYPE_DISK;
Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);
If Res <> 0 then Exit;
While true do
Begin
Count := -1;
BufSize := 8192;
Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);
If Res = ERROR_NO_MORE_ITEMS then Exit;
If (Res <> 0) then Exit;
p := PNetResourceArr(Buf);
For i := 0 to Count - 1 do
Begin
{ Ağdaki kullanıcı isimlerini Userlist listesine ekle}
UserList.Add(p^.lpRemoteName + 2);
Inc(p);
End;
End;
Res := WNetCloseEnum(lphEnum);
If Res <> 0 then Raise Exception(Res);
Finally
FreeMem(Buf);
Execute := True;
End;
End;
procedure Register;
begin
RegisterComponents('Sil', [TNetUsers]);
end;
end.
//kullanımı
{
procedure TForm1.Button1Click(Sender: TObject);
begin
NETUSERS1.EXECUTE;
listbox1.items.assign(netusers1.userlist)
end;}
Tanımlı ağ sürücüleri
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function GetNetworkDriveMappings(
sl : TStrings ) : integer;
var
i : integer;
sNetPath : string;
dwMaxNetPathLen : DWord;
begin
sl.Clear;
dwMaxNetPathLen := MAX_PATH;
SetLength( sNetPath,
dwMaxNetPathLen );
for i := 0 to 25 do
begin
if( NO_ERROR =
Windows.WNetGetConnection(
PChar(
'' + Chr( 65 + i ) + ':' ),
PChar( sNetPath ),
dwMaxNetPathLen ) )then
begin
sl.Add( Chr( 65 + i ) + ': ' +
sNetPath );
end;
end;
Result := sl.Count;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
sl : TStrings;
nMappingsCount,
i : integer;
begin
sl := TStringList.Create;
nMappingsCount :=
GetNetworkDriveMappings( sl );
for i := 0 to nMappingsCount-1 do
begin
MessageBox( 0,
PChar( sl.Strings[ i ] ),
'Network sürücü tanımları',
MB_OK );
end;
listbox1.items.assign(sl);
sl.Free;
end;
end.
3. Ses ve Grafik işlemleri
Bu bölümde, delphi uygulamalarında yapılabilecek ses ve grafik işlemleri ile ilgili püf noktaları ve kod örnekleri yer almaktadır.
Farklı çizgiler
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
public
DrawNow : Integer;
end;
var
Form1: TForm1;
procedure DrawPoint(x,y : Integer;lpData : LParam); stdcall;
implementation
{$R *.DFM}
procedure DrawPoint(x,y : Integer;lpData : LParam);
begin
with TObject(lpData) as TForm1 do begin
if DrawNow mod 4 = 0 then
Canvas.Rectangle(x-2,y-2,x+3,y+3);
Inc(DrawNow);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
DrawNow := 0;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
LineDDA(0,0,Width,Height,@DrawPoint,Integer(Self));
end;
StringGrid içerisinde BMP
Şekil 5 : StringGrid bileşeni içerisinde BMP gösterimi
bmpinsgrd.Pas dosyası;
unit bmpinsgrd;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,Grids;
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
procedure StringGrid1DrawCell(Sender: TObject; Col, Row: Integer; Rect: TRect; State: TGridDrawState);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
Bmp : TBitmap;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
{$R BMPS.RES}
procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Integer; Rect: TRect; State: TGridDrawState);
var
SRect,DRect : TRect;
begin
(Sender as TStringGrid).Canvas.FillRect(Rect);
if (Sender as TStringGrid).Cells[Row,Col] = '@' then
begin
SRect := Classes.Rect(0,0,Bmp.Width,Bmp.Height);
DRect.Left := Rect.Left+3;
DRect.Top := Rect.Top+(Rect.Bottom-Rect.Top-Bmp.Height) div 2;
DRect.Right := DRect.Left+SRect.Right+1;
DRect.Bottom := DRect.Top+SRect.Bottom+1;
(Sender as TStringGrid).Canvas.BrushCopy( DRect,Bmp,SRect,clOlive);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Bmp := TBitmap.Create;
Bmp.LoadFromResourceName(HInstance,'BMP');
StringGrid1.Cells[1,1] := '@';
StringGrid1.Cells[3,1] := '@';
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Bmp.Free;
end;
end.
bmpinsgrd.DFM dosyası;
object Form1: TForm1
Left = 200
Top = 108
Width = 310
Height = 258
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object StringGrid1: TStringGrid
Left = 8
Top = 8
Width = 289
Height = 217
TabOrder = 0
OnDrawCell = StringGrid1DrawCell
ColWidths = (
64
70
52
47
40)
RowHeights = (
24
79
24
66
12)
end
end
Tonlamalı(Gradient) Form
procedure TForm1.FormPaint(Sender: TObject);
const N=100;
var Y:Integer;
Cl:TColor;
begin
for Y:=0 to N-1 do
with Canvas do
begin
Cl:=RGB(0,0,Round(50+205*(Y/N)));
Pen.Color:=Cl;
Brush.Color:=cl;
Rectangle(0,Round(ClientHeight*(Y/N)),ClientWidth,Round(ClientHeight*((Y+1)/N)));
end;
end;
procedure TForm1.FormResize(Sender: TObject);
begin
Invalidate;
end;
Ekran yakalama
Masaüstü görüntüsünün yakalanıp, form üzerine aktarılması;
procedure Tform1.GrabScreen;
var
DeskTopDC: HDc;
DeskTopCanvas: TCanvas;
DeskTopRect: TRect;
begin
DeskTopDC := GetWindowDC(GetDeskTopWindow);
DeskTopCanvas := TCanvas.Create;
DeskTopCanvas.Handle := DeskTopDC;
DeskTopRect := Rect(0,0,Screen.Width,Screen.Height);
Canvas.CopyRect(DeskTopRect,DeskTopCanvas,DeskTopRect);
ReleaseDC(GetDeskTopWindow,DeskTopDC);
end;
veya;
var width, height : word;
desktop : HDC;
begin
width := Screen.Width;
height := Screen.Height;
desktop := GetWindowDC(GetDesktopWindow);
Image1.Picture.Bitmap.Width := width;
Image1.Picture.Bitmap.Height := height;
BitBlt( Image1.Picture.Bitmap.Canvas.Handle, 0, 0,
width, height, desktop, 0, 0, SRCCOPY );
end;
Bir resmi, Bmp formatından Jpeg formatına çevirme
var bmp : TImage;
jpg : TJpegImage;
begin
bmp := TImage.Create(nil);
jpg := TJpegImage.Create;
bmp.picture.bitmap.LoadFromFile ( 'c:\picture.bmp' );
jpg.Assign( bmp.picture.bitmap );
jpg.SaveToFile ( 'c:\picture.jpg' );
jpg.Free;
bmp.Free;
end;
Duvar kağıdı değiştirme
Programınızın çalışması esnasında, arzu ettiğiniz bir duvar kağıdının kullanılmasını ister misiniz? İşte bunu halletmenin yolu…
procedure TForm1.FormCreate(Sender: TObject);
var
Reg: TRegIniFile;
begin
Reg := TRegIniFile.Create('Control Panel');
Reg.WriteString('desktop', 'Wallpaper',
'c:\windows\forest.bmp');
Reg.WriteString('desktop', 'TileWallpaper', '1');
Reg.Free;
SystemParametersInfo(SPI_SETDESKWALLPAPER,0, nil, SPIF_SENDWININICHANGE);
end;
Sistemin kullanabileceği renk sayısının bulunması
Garfik işlemleri yaparken, sistemde geçerli olan renk ayarına ihtiyaç olabilir. Aşağıdaki fonksiyon sistemin desteklemekte olduğu renk sayısını bulmaktadır.
function GetColorsCount : integer;
var
h : hDC;
begin
Result := 0;
try
h := GetDC( 0 );
Result :=1 shl (GetDeviceCaps(h, PLANES) *
GetDeviceCaps(h, BITSPIXEL));
finally
ReleaseDC( 0, h );
end;
end;
DbGrid alanlarının renklendirilmesi
TDBGrid bileşeninde gösterilen bilginin, daha kolay okunabilmesi, ve kullanıcının dikkatinin bazı özel durumlara çekilebilmesi için, hücreleri renklendirmek faydalı olabilir.
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect:
TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
var
holdColor: TColor;
begin
holdColor := DBGrid1.Canvas.Brush.Color if Column.FieldName = 'EmpNo' then
if (Column.Field.AsInteger mod 2 0) then begin
DBGrid1.Canvas.Brush.Color := clGreen;
DBGrid1.DefaultDrawColumnCell(Rect, DataCol, Column, State);
DBGrid1.Canvas.Brush.Color := holdColor;
end;
end;
ListBox bileşenlerinde Renkli satırlar
Bir Tlistbox içerisinde bulunan satırların, belli şartlara göre farklı renklerde olması mümkündür. Aşağıdaki kod örneğinde bunun yapılışı gösterilmektedir. Dikkat edilmesi gereken en önemli husus, Listbox bileşeninin Style özelliği lbOwnerDrawFixed olmalıdır.
//Style= lbOwnerDrawFixed olmalı…
procedure TForm1.ListBox1DrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
With ( Control As TListBox ).Canvas Do
Begin
Case Index Of
0:
Begin
Font.Color := clBlue;
Brush.Color := clYellow;
End;
1:
Begin
Font.Color := clRed;
Brush.Color := clLime;
End;
2:
Begin
Font.Color := clGreen;
Brush.Color := clFuchsia;
End;
End;
FillRect(Rect);
TextOut(Rect.Left, Rect.Top, ( Control As TListBox ).Items[Index]);
End;
end;
Renk Paletlerinin yaratılması ve kullanımı
Delphi uygulamasında çizim yapılırken, gereken paletin yaratılması ve kullanılması nasıl olur?
Eğer palet değiştirme yolu ile animasyon yapılacaksa, en az 256 renk modunda çalışılmalı ve, aşağıdaki kod örneğinde geçen bütün PC_NOCOLLAPSE değerleri PC_RESERVED olarak değiştirilmelidir.
Palet yaratmanın yanı sıra, yapılması gereken diğer işlemler de şunlardır.
1. Formun GetPalette davranışı,yeni paleti döndürecek şekilde değiştirilmelidir.
2. Boyamaya başlamadan hemen önce, yeni palet seçilmelidir.
OldPal := SelectPalette(Canvas.Handle, NewPalette, False);
RealizePalette(Canvas.Handle);
SelectPalette(Canvas.Handle, OldPal, False);
3. İşlem tamamlandıktan sonra palet yok edilmelidir.
4. Renk değeri almak için, RGB fonksiyonu yerine PaletteRGB fonksiyonu kullanılmalıdır.
function CreateIdentityPalette(const aRGB; nColors : Integer) : HPALETTE;
type
QA = Array[0..255] of TRGBQUAD;
var
Palette : PLOGPALETTE;
PalSize : Word;
ScreenDC : HDC;
I : Integer;
nStaticColors : Integer;
nUsableColors : Integer;
begin
PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 256;
GetMem(Palette, PalSize);
try
with Palette^ do
begin
palVersion := $0300;
palNumEntries := 256;
ScreenDC := GetDC(0);
try
if (GetSystemPaletteUse(ScreenDC) = SYSPAL_NOSTATIC)
then
begin
{$R-}
for i := 0 to (nColors-1) do
with palPalEntry[i], QA(aRGB)[I] do
begin
peRed := rgbRed;
peGreen := rgbGreen;
peBlue := rgbBlue;
peFlags := PC_NOCOLLAPSE;
end;
for i := nColors to 255 do
palPalEntry[i].peFlags := PC_NOCOLLAPSE;
I := 255;
with palPalEntry[i] do
begin
peRed := 255;
peGreen := 255;
peBlue := 255;
peFlags := 0;
end;
with palPalEntry[0] do
begin
peRed := 0;
peGreen := 0;
peBlue := 0;
peFlags := 0;
end;
{$R+}
end
else
begin
nStaticColors := GetDeviceCaps(ScreenDC, NUMRESERVED);
GetSystemPaletteEntries(ScreenDC, 0, 256, palPalEntry);
{$R-}
nStaticColors := nStaticColors shr 1;
for i:= 0 to (nStaticColors-1) do
palPalEntry[i].peFlags := 0;
nUsableColors := nColors - nStaticColors;
for I := nStaticColors to (nUsableColors-1) do
with palPalEntry[i], QA(aRGB)[i] do
begin
peRed := rgbRed;
peGreen := rgbGreen;
peBlue := rgbBlue;
peFlags := PC_NOCOLLAPSE;
end;
for i := nUsableColors to (255-nStaticColors) do
palPalEntry[i].peFlags := PC_NOCOLLAPSE;
for i := (256 - nStaticColors) to 255 do
palPalEntry[i].peFlags := 0;
end;
finally
ReleaseDC(0, ScreenDC);
end;
end;
Result := CreatePalette(Palette^);
finally
FreeMem(Palette, PalSize);
end;
end;
procedure ClearSystemPalette;
var
Palette : PLOGPALETTE;
PalSize : Word;
ScreenDC : HDC;
I : Word;
const
ScreenPal : HPALETTE = 0;
begin
PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 255;
GetMem(Palette, PalSize);
try
FillChar(Palette^, PalSize, 0);
Palette^.palVersion := $0300;
Palette^.palNumEntries := 256;
{$R-}
For I := 0 to 255 do
With Palette^.palPalEntry[I] do
peFlags := PC_NOCOLLAPSE;
{$R+}
ScreenDC := GetDC(0);
try
ScreenPal := CreatePalette(Palette^);
if ScreenPal <> 0
then
begin
ScreenPal := SelectPalette(ScreenDC,ScreenPal,FALSE);
RealizePalette(ScreenDC);
ScreenPal := SelectPalette(ScreenDC,ScreenPal,FALSE);
DeleteObject(ScreenPal);
end;
finally
ReleaseDC(0, ScreenDC);
end;
finally
FreeMem(Palette, PalSize);
end;
end;
Müzik CD si çalınırken, Track sayısının okunması
Çalınmakta olan müzik CD'sinin, hangi Track da olduğunun anlaşılması için aşağıdaki kod örneği kullanılabilir.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, MPlayer,mmsystem;
type
TForm1 = class(TForm)
Timer1: TTimer;
Label1: TLabel;
Label2: TLabel;
MediaPlayer1: TMediaPlayer;
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Timer1Timer(Sender: TObject);
var Trk, Min, Sec: Word;
begin
with MediaPlayer1 do
begin
Trk:= MCI_TMSF_TRACK(Position);
Min:=MCI_TMSF_MINUTE(Position);
Sec:=MCI_TMSF_SECOND(Position);
Label1.Caption:=Format('%.2d',[Trk]);
Label2.Caption:=Format('%.2d:%.2d',[Min,Sec]);
end;
end;
end.
Ekran çözünürlüğü değiştirme
Bilgisayarda kullanılan ekran çözünürlüğü değerleri, normalde masa üstüne sağ fare tuşu ile tıklanarak açılan PopUp menüden, özellikler seçeneği kullanılarak yapılır. Bu işlemin kod ile yapılması gerekirse;
Desteklenen ekran çözünürlükleri şu şekilde tespit edilebilir.
unit unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
DC : THandle;
Bits : Integer;
HRes : Integer;
VRes : Integer;
DM : TDevMode;
ModeNum : LongInt;
Ok : Bool;
begin
DC := Canvas.Handle;
Bits := GetDeviceCaps(DC, BITSPIXEL);
HRes := GetDeviceCaps(DC, HORZRES);
VRes := GetDeviceCaps(DC, VERTRES);
Edit1.Text := Format('%d bits, %d x %d',[Bits, HRes, VRes]);
ModeNum := 0;
EnumDisplaySettings(Nil, ModeNum, DM);
ListBox1.Items.Add(Format('%d bits, %d x %d',
[DM.dmBitsPerPel, DM.dmPelsWidth, DM.dmPelsHeight]));
Ok := True;
While Ok do
Begin
Inc(ModeNum);
Ok := EnumDisplaySettings(Nil, ModeNum, DM);
If Ok Then ListBox1.Items.Add(Format('%d bits, %d x %d',
[DM.dmBitsPerPel, DM.dmPelsWidth, DM.dmPelsHeight]));
End;
end;
end.
Çözünürlükleri listelemenin bir adım ilerisi, istenen çözünürlüğü seçip uygulamaktır. Aşağıdaki unit de tespit edilen çözünürlüklerden seçilen sisteme uygulanmaktadır.
Ubit1Pas.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
i : Integer;
DevMode : TDevMode;
begin
i := 0;
while EnumDisplaySettings(nil,i,Devmode) do begin
with Devmode do
ListBox1.Items.Add(Format('%dx%d %d Colors',[dmPelsWidth,dmPelsHeight,1 shl dmBitsperPel]));
Inc(i);
end;
end;
procedure TForm1.ListBox1Click(Sender: TObject);
begin
Button1.Enabled := Listbox1.ItemIndex >= 0;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
DevMode : TDevMode;
begin
EnumDisplaySettings(nil,Listbox1.ItemIndex,Devmode);
ChangeDisplaySettings(DevMode,0);
end;
end.
Unit1.dfm
object Form1: TForm1
Left = 334
Top = 191
Width = 306
Height = 320
Caption = 'Ekran çözünürlükleri'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -14
Font.Name = 'MS Sans Serif'
Font.Style = []
OnCreate = FormCreate
PixelsPerInch = 120
TextHeight = 16
object ListBox1: TListBox
Left = 20
Top = 10
Width = 267
Height = 218
ItemHeight = 16
TabOrder = 0
OnClick = ListBox1Click
end
object Button1: TButton
Left = 110
Top = 241
Width = 92
Height = 32
Caption = 'Değiştir'
Enabled = False
TabOrder = 1
OnClick = Button1Click
end
end
Bmp resminin panoya yapıştırılmsı ve Panodan kopyalaması
Pano kullanımının bir başka örneğinin uygulandığı, kod örneğinde, BMP formatındaki bir resmin, panoya kopyalanması ve panodan alınması gösterilmektedir.
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls,
clipbrd;
type
TForm1 = class(TForm)
BaseKeyPanel: TPanel;
Image2: TImage;
Button1: TButton;
Image1: TImage;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
Var
BitMap : TBitmap;
begin
BitMap:=TBitMap.Create;
BitMap.Height:=BaseKeyPanel.Height;
BitMap.Width:=BaseKeyPanel.Width;
BitBlt(BitMap.Canvas.Handle, 0 {Left}, 0{Top},
BaseKeyPanel.Width, image1.Height,
GetDC(BaseKeyPanel.Handle), 0, 0, SRCCOPY);
Clipboard.Assign(BitMap);
bitmap.free;
End;
procedure TForm1.Button2Click(Sender: TObject);
Var
BitMap : TBitmap;
begin
BitMap:=TBitMap.Create;
bitmap.assign(clipboard);
Image2.Canvas.Draw(0, 0, Bitmap);
bitmap.free;
end;
end.
Form1.dfm
object Form1: TForm1
Left = 200
Top = 111
Width = 554
Height = 316
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 120
TextHeight = 16
object Image2: TImage
Left = 184
Top = 64
Width = 105
Height = 105
end
object BaseKeyPanel: TPanel
Left = 48
Top = 80
Width = 105
Height = 81
Caption = 'BaseKeyPanel'
TabOrder = 0
object Image1: TImage
Left = 1
Top = 1
Width = 103
Height = 79
Align = alClient
end
end
object Button1: TButton
Left = 48
Top = 32
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 1
OnClick = Button1Click
end
object Button2: TButton
Left = 192
Top = 32
Width = 75
Height = 25
Caption = 'Button2'
TabOrder = 2
OnClick = Button2Click
end
end
Bir EXE den ikonun alınp başka bir yere çizilmesi
Herhangi bir program dosyasında kullanılan ikonun, alınmasını sağlayan bir fonksiyon.
implementation
USES ShellApi;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
IconIndex : word;
h : hIcon;
begin
IconIndex := 0;
h :=
ExtractAssociatedIcon(hInstance,
'C:\WINDOWS\NOTEPAD.EXE',
IconINdex);
DrawIcon(Form1.Canvas.Handle,
10,
10,
h);
end;
end.
İkon resminin, buton üzerinde kullanılması
Not : image bileşenlerinin picture bilgileri, silinmiştir.
object Form1: TForm1
Left = 200
Top = 108
Width = 278
Height = 372
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 96
TextHeight = 13
object SpeedButton1: TSpeedButton
Left = 8
Top = 16
Width = 65
Height = 57
end
object FileListBox1: TFileListBox
Left = 80
Top = 16
Width = 169
Height = 313
ItemHeight = 13
TabOrder = 0
OnClick = FileListBox1Click
end
end
unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, Buttons, StdCtrls, FileCtrl;
type
TForm1 = class(TForm)
FileListBox1: TFileListBox;
SpeedButton1: TSpeedButton;
procedure FileListBox1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses shellapi;
{$R *.DFM}
procedure TFORM1.FileListBox1Click(Sender: TObject);
var
MyIcon: TIcon;
MyBitMap : TBitmap;
strFileName:STRING;
cStrFileName:PCHAR;
begin
MyIcon := TIcon.Create;
MyBitMap := TBitmap.Create;
try
{ get the file name and the icon associated with it}
strFileName := FileListBox1.Items[FileListBox1.ItemIndex];
StrPCopy(cStrFileName, strFileName);
MyIcon.Handle := ExtractIcon(hInstance, cStrFileName, 0);
{ draw the icon onto the bitmap for the speed button }
SpeedButton1.Glyph := MyBitMap;
SpeedButton1.Glyph.Width := MyIcon.Width;
SpeedButton1.Glyph.Height := MyIcon.Height;
SpeedButton1.Glyph.Canvas.Draw(0,0, MyIcon);
finally
MyIcon.Free;
MyBitMap.Free;
end;
end;
end.
Grafik çizme işlemi
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure grapf;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure tform1.grapf;
var
x,l: Integer;
y,a: Double;
begin
Image1.Picture.Bitmap := TBitmap.Create;
Image1.Picture.Bitmap.Width := Image1.Width;
Image1.Picture.Bitmap.Height := Image1.Height; {These three lines could
go in Form1.Create instead}
l := Image1.Picture.Bitmap.Width;
for x := 0 to l do
begin
a := (x/l) * 2 * Pi; {Convert position on X to angle between 0 & 2Pi}
y := Sin(a); {Your function would go here}
y := y * (Image1.Picture.Bitmap.Height / 2); {Scale Y so it fits}
y := y * -1; {Invert Y, the screen top is 0 !}
y := y + (Image1.Picture.Bitmap.Height / 2); {Add offset for middle 0}
Image1.Picture.Bitmap.Canvas.Pixels[Trunc(x), Trunc(y)] := clBlack;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
grapf
end;
end.
Hareketli grafik çizimi
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
BitMap : TBitmap;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Bitmap := TBitmap.Create;
Bitmap.Width := 400;
Bitmap.Height := 400;
PaintBox1.Width := 200;
PaintBox1.Height := 200;
With Bitmap.Canvas do
begin
Pen.Color := clNavy;
Ellipse(0,0,399,399);
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Bitmap.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Limit : Word;
I : Word;
PBBottom, PBRight : Word;
begin
PBBottom := PaintBox1.Height - 1;
PBRight := PaintBox1.Width - 1;
Limit := Bitmap.Width - PaintBox1.Width;
For I := 0 to Limit do
PaintBox1.Canvas.CopyRect(Rect(0,0,PBRight,PBBottom),
Bitmap.Canvas, Rect(I,0,I+PBRight,PBBottom));
end;
end.
Unit1.dfm
object Form1: TForm1
Left = 200
Top = 108
Width = 240
Height = 238
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object PaintBox1: TPaintBox
Left = 64
Top = 24
Width = 105
Height = 105
end
object Button1: TButton
Left = 80
Top = 144
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
end
Panoya resim kopyalama
bütün formu panoya kopyalar
procedure TForm1.Button2Click(Sender: TObject);
//uses clipbrd
Var
Image : TImage;
BitMap : TBitmap;
Begin
Image:=TImage.Create(Self);
BitMap:=TBitMap.Create;
BitMap.Width:=ClientWidth;
BitMap.Height:=ClientHeight;
BitBlt(BitMap.Canvas.Handle, 0, 0, ClientWidth, ClientHeight, GetDC(Handle),
0, 0, SRCCOPY);
Image.Picture.Graphic:=BitMap;
Clipboard.Assign(Image.Picture);
BitMap.Free;
Image.Free
end;
Bir remin şeffaf olarak başka bir resim üzerine yapıştırılması
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
ColorDialog1: TColorDialog;
Panel1: TPanel;
Button2: TButton;
Image2: TImage;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure DrawTransparent(t: TCanvas; x,y: Integer; s: TBitmap; TrCol: TColor);
end;
var
Form1: TForm1;
bmp:tbitmap;
clr:tcolor;
implementation
{$R *.DFM}
procedure tform1.DrawTransparent(t: TCanvas; x,y: Integer; s: TBitmap; TrCol: TColor);
var
bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap;
oldcol: Longint;
begin
try
bmpAND := TBitmap.Create;
bmpAND.Width := s.Width;
bmpAND.Height := s.Height;
bmpAND.Monochrome := True;
oldcol := SetBkColor(s.Canvas.Handle, ColorToRGB(TrCol));
BitBlt(bmpAND.Canvas.Handle, 0,0,s.Width,s.Height, s.Canvas.Handle, 0,0, SRCCOPY);
SetBkColor(s.Canvas.Handle, oldcol);
bmpINVAND := TBitmap.Create;
bmpINVAND.Width := s.Width;
bmpINVAND.Height := s.Height;
bmpINVAND.Monochrome := True;
BitBlt(bmpINVAND.Canvas.Handle, 0,0,s.Width,s.Height, bmpAND.Canvas.Handle, 0,0, NOTSRCCOPY);
bmpXOR := TBitmap.Create;
bmpXOR.Width := s.Width;
bmpXOR.Height := s.Height;
BitBlt(bmpXOR.Canvas.Handle, 0,0,s.Width,s.Height, s.Canvas.Handle, 0,0, SRCCOPY);
BitBlt(bmpXOR.Canvas.Handle, 0,0,s.Width,s.Height, bmpINVAND.Canvas.Handle, 0,0, SRCAND);
bmpTarget := TBitmap.Create;
bmpTarget.Width := s.Width;
bmpTarget.Height := s.Height;
BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, t.Handle, x,y, SRCCOPY);
BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, bmpAND.Canvas.Handle, 0,0, SRCAND);
BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, bmpXOR.Canvas.Handle, 0,0, SRCINVERT);
BitBlt(t.Handle, x,y,s.Width,s.Height, bmpTarget.Canvas.Handle, 0,0, SRCCOPY);
finally
bmpXOR.Free;
bmpAND.Free;
bmpINVAND.Free;
bmpTarget.Free;
end;{End of TRY section}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
DrawTransparent(image1.Canvas, 1,1, bmp, clr);
image1.Invalidate;
image1.repaint;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
bmp:=tbitmap.create;
bmp.width:=image1.width;
bmp.height:=image1.height;
bmp.assign(image2.picture);
// clr:=tcolor.create;;
clr:=clgreen;
panel1.color:=clr;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
bmp.free;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if colordialog1.execute then
clr:=colordialog1.Color;
panel1.color:=clr;
end;
end.
Unit1.dfm
object Form1: TForm1
Left = 200
Top = 108
Width = 617
Height = 302
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object Image1: TImage
Left = 264
Top = 8
Width = 329
Height = 201
Stretch = True
end
object Image2: TImage
Left = 8
Top = 8
Width = 249
Height = 201
Stretch = True
end
object Button1: TButton
Left = 144
Top = 224
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
object Panel1: TPanel
Left = 304
Top = 216
Width = 113
Height = 41
Caption = 'Panel1'
TabOrder = 1
object Button2: TButton
Left = 22
Top = 8
Width = 75
Height = 25
Caption = 'Button2'
TabOrder = 0
OnClick = Button2Click
end
end
object ColorDialog1: TColorDialog
Ctl3D = True
Left = 112
Top = 352
end
end
Palet değiştirme
Palet.pas
unit palet;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls, ExtDlgs;
type
TForm1 = class(TForm)
Button1: TButton;
OpenPictureDialog1: TOpenPictureDialog;
SavePictureDialog1: TSavePictureDialog;
Button2: TButton;
Button3: TButton;
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure ScrambleBitmap;
end;
var
Form1: TForm1;
bitmap:tbitmap;
pal: PLogPalette;
implementation
{$R *.DFM}
procedure Tform1.ScrambleBitmap;
var
hpal: HPALETTE;
i: Integer;
begin
{$R-}
pal := nil;
try
GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
pal.palVersion := $300;
pal.palNumEntries := 256;
for i := 0 to 255 do
begin
pal.palPalEntry[i].peRed := Random(255);
pal.palPalEntry[i].peGreen :=Random(255);
pal.palPalEntry[i].peBlue := Random(255);
end;
hpal := CreatePalette(pal^);
if hpal <> 0 then
Bitmap.Palette := hpal;
finally
FreeMem(pal);
end;
{$R+}
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
bitmap:=tbitmap.create;
bitmap.loadfromfile('c:\program files\borland\delphi 3\images\splash\256color\finance.bmp');
end;
procedure TForm1.FormPaint(Sender: TObject);
var
x, y: Integer;
begin
y := 0;
while y < Height do
begin
x := 0;
while x < Width do
begin
Canvas.Draw(x, y, Bitmap);
x := x + Bitmap.Width;
end;
y := y + Bitmap.Height;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ScrambleBitmap;
Invalidate;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if openpicturedialog1.execute then
bitmap.loadfromfile(openpicturedialog1.filename);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
if savepicturedialog1.execute then begin
bitmap.loadfromfile(savepicturedialog1.filename);
FormPaint(sender);
invalidate;
end;
end;
end.
Palet.dfm
object Form1: TForm1
Left = 200
Top = 108
Width = 696
Height = 480
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OnCreate = FormCreate
OnPaint = FormPaint
PixelsPerInch = 96
TextHeight = 13
object Button1: TButton
Left = 208
Top = 416
Width = 75
Height = 25
Caption = 'Palet değiştir'
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 24
Top = 416
Width = 75
Height = 25
Caption = 'Resim Aç'
TabOrder = 1
OnClick = Button2Click
end
object Button3: TButton
Left = 112
Top = 416
Width = 81
Height = 25
Caption = 'Resim Kaydet'
TabOrder = 2
OnClick = Button3Click
end
object OpenPictureDialog1: TOpenPictureDialog
Filter =
'All (*.bmp;*.ico;*.emf;*.wmf)|*.bmp;*.ico;*.emf;*.wmf|Bitmaps (*' +
'.bmp)|*.bmp|Icons (*.ico)|*.ico|Enhanced Metafiles (*.emf)|*.emf' +
'|Metafiles (*.wmf)|*.wmf'
Left = 592
Top = 392
end
object SavePictureDialog1: TSavePictureDialog
Filter =
'All (*.bmp;*.ico;*.emf;*.wmf)|*.bmp;*.ico;*.emf;*.wmf|Bitmaps (*' +
'.bmp)|*.bmp|Icons (*.ico)|*.ico|Enhanced Metafiles (*.emf)|*.emf' +
'|Metafiles (*.wmf)|*.wmf'
Left = 512
Top = 392
end
end
Panodaki metnin diskteki bir dosyaya kaydedilmesi
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Clipbrd, StdCtrls ;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function SaveClipboardTextDataToFile(
sFileTo : string ) : boolean;
var
ps1,
ps2 : PChar;
dwLen : DWord;
tf : TextFile;
hData : THandle;
begin
Result := False;
with Clipboard do
begin
try
Open;
if( HasFormat( CF_TEXT ) ) then
begin
hData :=
GetClipboardData( CF_TEXT );
ps1 := GlobalLock( hData );
dwLen := GlobalSize( hData );
ps2 := StrAlloc( 1 + dwLen );
StrLCopy( ps2, ps1, dwLen );
GlobalUnlock( hData );
AssignFile( tf, sFileTo );
ReWrite( tf );
Write( tf, ps2 );
CloseFile( tf );
StrDispose( ps2 );
Result := True;
end;
finally
Close;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SaveClipboardTextDataToFile('c:\sil\clip.asc');
end;
end.
4. Form ve Pencere işlemleri
Bu bölümde, Delphi uygulamaları içerisinde gerekebilecek form ve pencere işlemleri ile ilgili Püf noktaları ve kod örnekleri yer almaktadır.
Masa üstündeki ikonların saklanması
Aşağıdaki program çalıştırıldığında, görev çubuğu üzerindeki uyarı bölümünde bir ikon olarak görünür. Bu ikon üzerinde tıklandığında desktop üzerindeki ikonlar saklanır, bir kez daha basıldığında ise geri gelir.
program DeskPop;
uses
Windows, Messages, ShellAPI, sysutils;
{$R *.RES}
const
AppName = 'DeskTop Sakla';
var
x: integer;
tid: TNotifyIconData;
WndClass: array[0..50] of char;
procedure Panic (szMessage: PChar);
begin
if szMessage <> Nil then
MessageBox (0, szMessage, AppName, mb_ok);
Halt (0);
end;
procedure HandleCommand (Wnd: hWnd; Cmd: Word);
begin
case Cmd of
Ord ('A'): MessageBox (0, 'Merhaba', AppName, mb_ok);
Ord ('E'): PostMessage (Wnd, wm_Close, 0, 0);
end;
end;
function DummyWindowProc (Wnd: hWnd; Msg, wParam: Word; lParam: LongInt): LongInt; stdcall;
var
TrayHandle: THandle;
dc: hDC;
i: Integer;
pm: HMenu;
pt: TPoint;
begin
DummyWindowProc := 0;
StrPCopy(@WndClass[0], 'Progman');
TrayHandle := FindWindow(@WndClass[0], nil);
case Msg of
wm_Create:
begin
tid.cbSize := sizeof (tid);
tid.Wnd := Wnd;
tid.uID := 1;
tid.uFlags := nif_Message or nif_Icon or nif_Tip;
tid.uCallBackMessage := wm_User;
tid.hIcon := LoadIcon (hInstance, 'MAINICON');
lstrcpy (tid.szTip,'Desktop is on');
Shell_NotifyIcon (nim_Add, @tid);
end;
wm_Destroy:
begin
Shell_NotifyIcon (nim_Delete, @tid);
PostQuitMessage (0);
ShowWindow(TrayHandle, SW_RESTORE);
end;
wm_Command:
begin
HandleCommand (Wnd, LoWord (wParam));
Exit;
end;
wm_User: // Had a tray notification - see what to do
if (lParam = wm_LButtonDown) then
begin
if x = 0 then
begin
ShowWindow(TrayHandle, SW_HIDE);
//tid.hIcon := LoadIcon (hInstance, 'offICON');
lstrcpy (tid.szTip,'Desktop Kapalı');
Shell_NotifyIcon (NIM_MODIFY, @tid);
x:=1
end else
begin
ShowWindow(TrayHandle, SW_RESTORE);
//tid.hIcon := LoadIcon (hInstance, 'ONICON');
lstrcpy (tid.szTip,'Desktop Açık');
Shell_NotifyIcon (NIM_MODIFY, @tid);
x:= 0;
end;
end else
if (lParam = wm_RButtonDown) then
begin
GetCursorPos (pt);
pm := CreatePopupMenu;
AppendMenu (pm, 0, Ord ('A'), 'Hakkında...');
AppendMenu (pm, mf_Separator, 0, Nil);
AppendMenu (pm, 0, Ord ('E'), 'Kapat');
SetForegroundWindow (Wnd);
dc := GetDC (0);
if TrackPopupMenu (pm, tpm_BottomAlign or tpm_RightAlign, pt.x,GetDeviceCaps(dc,HORZRES){pt.y}, 0, Wnd, Nil) then
SetForegroundWindow (Wnd);
DestroyMenu (pm)
end;
end;
DummyWindowProc := DefWindowProc (Wnd, Msg, wParam, lParam);
end;
procedure WinMain;
var
Wnd: hWnd;
Msg: TMsg;
cls: TWndClass;
begin
{ Previous instance running ? If so, exit }
if FindWindow (AppName, Nil) <> 0 then exit;
//Panic (AppName + ' is already running.');
{ window Sınıfını kaydettir }
FillChar (cls, sizeof (cls), 0);
cls.lpfnWndProc := @DummyWindowProc;
cls.hInstance := hInstance;
cls.lpszClassName := AppName;
RegisterClass (cls);
{ Boş pencereyi yarat }
Wnd := CreateWindow (AppName, AppName, ws_OverlappedWindow,
cw_UseDefault, cw_UseDefault, cw_UseDefault, cw_UseDefault,
0, 0, hInstance, Nil);
x:= 0;
if Wnd <> 0 then
begin
ShowWindow (Wnd, sw_Hide);
while GetMessage (Msg, 0, 0, 0) do
begin
TranslateMessage (Msg);
DispatchMessage (Msg);
end;
end;
end;
begin
WinMain;
end.
Bütün açık pencerelerin listelenmesi
Sistemde açık olan bütün pencerelerin listelenmesi için, EnumWindows fonksiyonu kullanılır.
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;
Farklı bir pencere
Standart Windows pencereleri, dikdörtgen veya kare şeklindedir. Değişik şekilli bir pencere yaratmak için;
var
hR : THandle;
begin
hR := CreateEllipticRgn(0,0,100,200);
SetWindowRgn(Handle,hR,True);
end;
Farklı pencereye bir başka örnek;
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, Buttons;
type
TForm1 = class(TForm)
SpeedButton1: TSpeedButton;
Image1: TImage;
procedure FormCreate(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
private
{ Private declarations }
procedure CreateParams(var Params: TCreateParams); override;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited createparams(params);
params.style:=params.style or ws_popup xor ws_dlgframe;
end;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
formrgn:hrgn;
begin
form1.brush.style:=bsclear;
GetWindowRgn(form1.Handle, formRgn);
DeleteObject(formRgn);
formrgn:=
CreateroundRectRgn(0,
0,form1.width,form1.height,form1.width,form1.height);
SetWindowRgn(form1.Handle, formrgn, TRUE);
end;
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
form1.close;
end;
end.
Üzerine bırakılan dosyalara duyarlı form
unit dragfile;
interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs;
type
TForm2 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure AcceptFiles( var msg : TMessage );
message WM_DROPFILES;
end;
var
Form2: TForm2;
implementation
uses
ShellAPI;
{$R *.DFM}
procedure TForm2.AcceptFiles( var msg : TMessage );
const
cnMaxFileNameLen = 255;
var
i,
nCount : integer;
acFileName : array [0..cnMaxFileNameLen] of char;
begin
nCount := DragQueryFile( msg.WParam,
$FFFFFFFF,
acFileName,
cnMaxFileNameLen );
for i := 0 to nCount-1 do
begin
DragQueryFile( msg.WParam, i,
acFileName, cnMaxFileNameLen );
MessageBox( Handle, acFileName, '', MB_OK );
end;
DragFinish( msg.WParam );
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
DragAcceptFiles( Handle, True );
end;
end.
Form başlığının saklanması
procedure TForm1.Createparams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
Style := (Style or WS_POPUP) and (not WS_DLGFRAME);
end;
Standart dışı formlar
Windows'un standart formlarından sıkılanlar için, farklı bir form.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
Panel4: TPanel;
Panel5: TPanel;
procedure FormResize(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormResize(Sender: TObject);
var
WindowRgn, HoleRgn : HRgn;
begin
WindowRgn := 0;
GetWindowRgn(Handle, WindowRgn);
DeleteObject(WindowRgn);
WindowRgn :=
CreateRectRgn(0,0,Width,Height);
HoleRgn :=
CreateRectRgn(Panel3.Width + 6,
Panel1.Height + 25,
Width - (Panel4.Width + 6),
Height - (Panel2.Height + 6));
CombineRgn(WindowRgn, WindowRgn,
HoleRgn, RGN_DIFF);
SetWindowRgn(Handle, WindowRgn, TRUE);
DeleteObject(HoleRgn);
end;
end.
object Form1: TForm1
Left = 216
Top = 178
AutoScroll = False
Caption = 'Form1'
ClientHeight = 453
ClientWidth = 688
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OnResize = FormResize
PixelsPerInch = 96
TextHeight = 13
object Button1: TButton
Left = 512
Top = 352
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
end
object Panel1: TPanel
Left = 0
Top = 0
Width = 688
Height = 5
Align = alTop
BevelOuter = bvNone
Color = clRed
TabOrder = 1
end
object Panel2: TPanel
Left = 0
Top = 443
Width = 688
Height = 10
Align = alBottom
BevelOuter = bvNone
Color = clRed
TabOrder = 2
end
object Panel3: TPanel
Left = 0
Top = 5
Width = 10
Height = 438
Align = alLeft
BevelOuter = bvNone
Color = clRed
TabOrder = 3
end
object Panel4: TPanel
Left = 678
Top = 5
Width = 10
Height = 438
Align = alRight
BevelOuter = bvNone
Color = clRed
TabOrder = 4
end
object Panel5: TPanel
Left = 10
Top = 5
Width = 668
Height = 438
Align = alClient
BevelOuter = bvLowered
Caption = 'Panel5'
TabOrder = 5
end
end
Form pozüsyonu
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
private
{ Private declarations }
public
{ Public declarations }
Procedure WMMove(Var Message : TWMMove); message WM_Move;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
Procedure TForm1.WMMove(Var Message : TWMMove);
begin
Caption := 'X = '+IntToStr(Message.XPos)+', Y = '+IntTOStr(Message.
YPos);
end;
end.
Ekran Çözünürlüğü
Tasarım ortamın gayet düzgün görünen bir formun başka bir bilgisayarda bozuk görünmesi oldukça can sıkıcıdır. Bu olayın sebebi faklı ekran çözünürlükleri ve yazı tipi ayarıdır. Bunu önlemek için uygulama içerisinde bazı kontroller yapmak gerekir.
Aşağıdaki kod örneğinde form ve üzerindeki kontrollerin sistemdeki ayarlara göre yeniden ölçeklenmesi gösterilmektedir.
implementation
const
{formlarımızın 800x600 ölçülerinde olmasını istiyorsak…}
ScreenWidth: LongInt = 800;
ScreenHeight: LongInt = 600;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
scaled := true;
if (screen.width <> ScreenWidth) then
begin
height:=longint(height)*longint(screen.height)DIV
ScreenHeight;
width := longint(width) * longint(screen.width) DIV ScreenWidth;
scaleBy(screen.width, ScreenWidth);
end;
end;
Bu işlemden sonra kontrollerdeki yazı tiplerinin de ölçeklenmesi gerekecektir. Bu işlem bir döngü içerisinde kolaylıkla yapılır. Fakat bu esnada ilgili bileşenin FONT özelliği bulunduğundan emin olunmalıdır. Bu kontrol için RTTI (Run Time Type Information) kullanılabilir.
USES typinfo;
var
i: integer;
begin
for i := componentCount - 1 downto 0 do
with components[i] do
begin
if GetPropInfo(ClassInfo, 'font') <> nil then
font.size := (NewFormWidth DIV OldFormWidth) * font.size;
end;
end;
Form başlık alanı üzerinde saat gösterilmesi
Formun Caption özelliğine dokunmadan, başlık alanı üzerinde saat bilgisi gösterimi şu şekilde olur.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
type
TForm1 = class(TForm)
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
dc:hdc;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
dc:=getwindowdc(handle);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
releasedc(handle,dc);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
thetime: array[0..80] of char;
begin
strpcopy(Thetime,timetostr(time));
canvas.font.color:=clred;
textout(dc,width div 2,5,thetime,strlen(thetime));
end;
end.
Form başlığının gizlenmesi
Form başlıkları, çalışma esnasında gizlenip tekrar gösterilebilir.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure sakla;
procedure goster;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure tform1.sakla;
var
save:longint;
begin
if borderstyle=bsnone then exit;
save:=getwindowlong(handle,gwl_style);
if (save and ws_caption)=ws_caption then
begin
case borderstyle of
bssingle,bssizeable: setwindowlong(handle,gwl_style,save and (not(ws_caption)) or ws_border);
bsdialog:setwindowlong(handle,gwl_style,save and (not(ws_caption)) or ds_modalframe or ws_dlgframe);
end;
height:=height-getsystemmetrics(sm_cycaption);
refresh;
end;
end;
procedure tform1.goster;
var
save:longint;
begin
if borderstyle=bsnone then exit;
save:=getwindowlong(handle,gwl_style);
if (save and ws_caption)<>ws_caption then
begin
case borderstyle of
bssingle,
bssizeable: setwindowlong(handle,gwl_style,save or ws_caption or ws_border);
bsdialog:setwindowlong(handle,gwl_style,save or ws_caption or ds_modalframe or ws_dlgframe);
end;
height:=height+getsystemmetrics(sm_cycaption);
refresh;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
sakla
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
goster
end;
end.
Formun başlık alanına buton yerleştirme
Kullandığınız formların başlık alanına buton ekleyip, bu butona bazı görevler yükleyebilirsiniz.
unit CapBtn;
interface
uses
Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TForm1 = class(TForm)
procedure FormResize(Sender: TObject);
private
CaptionBtn : TRect;
procedure DrawCaptButton;
procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;
procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;
procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;
procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;
procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
const
htCaptionBtn = htSizeLast + 1;
{$R *.DFM}
procedure TForm1.DrawCaptButton;
var
xFrame,
yFrame,
xSize,
ySize : Integer;
R : TRect;
begin
//Form eni ve boyu
xFrame := GetSystemMetrics(SM_CXFRAME);
yFrame := GetSystemMetrics(SM_CYFRAME);
//Başlık butonlarının eni ve boyu
xSize := GetSystemMetrics(SM_CXSIZE);
ySize := GetSystemMetrics(SM_CYSIZE);
//Yeni butonun yeri
CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,
yFrame + 2, xSize - 2, ySize - 4);
//Forma ait DC 'yi kullanarak,
//üzerine çizim yapılacak tuvali bul
Canvas.Handle := GetWindowDC(Self.Handle);
Canvas.Font.Name := 'Symbol';
Canvas.Font.Color := clBlue;
Canvas.Font.Style := [fsBold];
Canvas.Pen.Color := clYellow;
Canvas.Brush.Color := clBtnFace;
try
DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False);
R := Bounds(Width - xFrame - 4 * xSize + 2,
yFrame + 3, xSize - 6, ySize - 7);
with CaptionBtn do
Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');
finally
ReleaseDC(Self.Handle, Canvas.Handle);
Canvas.Handle := 0;
end;
end;
procedure TForm1.WMNCPaint(var Msg : TWMNCPaint);
begin
inherited;
DrawCaptButton;
end;
procedure TForm1.WMNCActivate(var Msg : TWMNCActivate);
begin
inherited;
DrawCaptButton;
end;
procedure TForm1.WMSetText(var Msg : TWMSetText);
begin
inherited;
DrawCaptButton;
end;
procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest);
begin
inherited;
with Msg do
if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then
Result := htCaptionBtn;
end;
procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);
begin
inherited;
if (Msg.HitTest = htCaptionBtn) then
ShowMessage('Hoops... yeni butona bastın');
end;
procedure TForm1.FormResize(Sender: TObject);
begin
//Başlık çubuğunun yeniden çizilmesini sağla
Perform(WM_NCACTIVATE, Word(Active), 0);
end;
end.
Açılır-Kapanır form
İşyeri kepengine benzer bir şekilde açılıp kapanabilen bir form yaratmak için kullanılabilecek kod örneği aşağıdadır. Açılma ve kapanma komutu, bu örnekte başlık alanı üzerinde sağ fare tuşuna basılarak verilmektedir.
unit KepengForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, Printers, Buttons, ShellAPI;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
FOldHeight : Integer;
procedure WMNCRButtonDown(var Msg : TWMNCRButtonDown); message WM_NCRBUTTONDOWN;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
FOldHeight := ClientHeight;
end;
procedure TForm1.WMNCRButtonDown(var Msg : TWMNCRButtonDown);
var
I : Integer;
begin
if (Msg.HitTest = HTCAPTION) then
if (ClientHeight = 0) then
begin
I := 0;
while (I < FOldHeight) do begin
I := I + 40;
if (I > FOldHeight) then
I := FOldHeight;
ClientHeight := I;
Application.ProcessMessages;
end;
end
else
begin
FOldHeight := ClientHeight;
I := ClientHeight;
//kapanma efekti için, I değerini doğrudan "0" a eşitlemek //yerine kademeli olarak azaltabilirsiniz.
I := 0;
ClientHeight := I;
Application.ProcessMessages;
end;
end;
end.
Pencerenin taşınması
Windows pencereleri, ekran üzerinde başlıklarından tutularak taşınırlar. Pencere alanından tutulareak da taşınabilmeleri için, WM_NCHITTEST mesajının yakalanıp, yordamının değiştirilmesi gerekir.
type
TForm1 = class(TForm)
public
procedure WMNCHitTest(var M: TWMNCHitTest); message WM_NCHitTest;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
inherited;
if M.Result = htClient then
M.Result := htCaption;
end;
5. Disk ve Dosya işlemleri
Sürücü listesi
procedure TForm1.Button2Click(Sender: TObject);
var drives : dword;
i : integer;
begin
drives := GetLogicalDrives;
for i := 0 to 25 do //ingilizce alfabede 25 harf var
if ( drives and ( 1 shl i )) > 0 then
Listbox1.Items.Add( Chr( i + 65 ));
end;
veya
procedure TForm1.Button1Click(Sender: TObject);
var buffer : array[0..500] of char;
temp : PChar;
typ : integer;
begin
GetLogicalDriveStrings( sizeof( buffer ), buffer );
temp := buffer;
while temp[0] <> #0 do
begin
typ := GetDriveType( temp );
with ListBox1.Items do
case typ of
DRIVE_REMOVABLE : Add( temp + ' removable' );
DRIVE_FIXED : Add( temp + ' Sabit Disk' );
DRIVE_REMOTE : Add( temp + ' Ağ üzerinde' );
DRIVE_CDROM : Add( temp + ' CD-ROM' );
DRIVE_RAMDISK : Add( temp + ' RAM-disk' );
else
Add( temp + ' Bilinmiyor' );
end;
temp := StrEnd( temp ) + 1;
end;
end;
Disket Sürücüsünde disket takılı mı ?
{$I-}
ChDir('a:\');
{$I+}
if IOResult <> 0 then
ShowMessage( 'a sürücüsünde Disket yok' );
Veya;
function DiskInDrive(const Drive: char): Boolean;
var
DrvNum: byte;
EMode: Word;
begin
result := false;
DrvNum := ord(Drive);
if DrvNum >= ord('a') then dec(DrvNum,$20);
EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
if DiskSize(DrvNum-$40) <> -1 then result := true
else messagebeep(0);
finally
SetErrorMode(EMode);
end;
end;
Çalışan uygulamanın bulunduğu dizin
procedure TForm1.Button1Click(Sender: TObject);
var
szFileName : array[0..99] of char;
szModuleName : array[0..19] of char;
iSize : integer;
begin
iSize := GetModuleFileName(GetModuleHandle(szModuleName),szFileName,
SizeOf(szFileName));
if iSize > 0 then
ShowMessage('Tam dizin : ' + StrPas(szFileName))
else
ShowMessage('Bulunamadı');
end;
Windows'un standart "BrowseFolder" Diyalog penceresinin kullanılması
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,ShlObj,ActiveX;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var BI:TBrowseInfo;
Buf:PChar;
Dir,Root:PItemIDList;
Alloc:IMalloc;
begin
SHGetMalloc(Alloc);
Buf:=Alloc.Alloc(Max_Path);
// Bu satır aranacak dizinleri sınırlar.
SHGetSpecialFolderLocation(Handle,CSIDL_PROGRAMS,Root);
with BI do
begin
hwndOwner:=Form1.Handle;
pidlRoot:=Root; // Eğer Nil olursa, bütün dizinler
// görüntülenir.
pszDisplayName:=Buf;
lpszTitle:=' İstediğiniz dizini seçiniz';
ulFlags:=0;
lpfn:=nil;
end;
try
Dir:=SHBrowseForFolder(BI);
if Dir<>Nil then
begin
SHGetPathFromIDList(Dir,Buf); // İstenen dizinin tam adı
ShowMessage(Buf);
Alloc.Free(Dir);
end;
finally
Alloc.Free(Root);
Alloc.Free(Buf);
end;
end;
end.
Seçilebilecek, diğer özel Klasör tipleri
CSIDL_BITBUCKET Geri dönüşüm kutusu
CSIDL_CONTROLS Kontrol panel klasörleri
CSIDL_DESKTOP Masaüstü klasörleri
CSIDL_DESKTOPDIRECTORY Masaüstü nesnelerini barındıran klasör
CSIDL_DRIVES Bilgisayarım klasörü
CSIDL_FONTS Font klasörü
CSIDL_NETHOOD Ağ komşuluğu klasörü
CSIDL_NETWORK Yukarıdakinin bir başka versiyonu
CSIDL_PERSONAL Şahsi klasör
CSIDL_PRINTERS Yazıcılar klasörü
CSIDL_PROGRAMS Başlat menüsündeki programlar klasörü
CSIDL_RECENT Son kullanılan dökümanlar klasörü
CSIDL_SENDTO Gönder (SendTo) klasörü
CSIDL_STARTMENU Başlat menüsünün tümü
CSIDL_STARTUP Otomatik başlat klasörü
CSIDL_TEMPLATES Döküman şablonları
Bir dizindeki dosyaların ve alt dizinlerin tümünün silinmesi
procedure removeTree (DirName: string);
var
FileSearch: SearchRec;
begin
chDir (DirName);
FindFirst ('*.*', Directory, FileSearch);
while (DosError = 0) do begin
if (FileSearch.name <> '.') AND (FileSearch.name <> '..') AND
( (FileSearch.attr AND Directory) <> 0)
then begin
if DirName[length(DirName)] = '\' then
removeTree (DirName+FileSearch.Name)
else
removeTree (DirName+'\'+FileSearch.Name);
ChDir (DirName);
end;
FindNext (FileSearch)
end;
FindFirst ('*.*', AnyFile, FileSearch);
while (DosError = 0) do begin
if (FileSearch.name <> '.') AND (FileSearch.name <> '..') then
Remove (workdir);
end;
FindNext (FileSearch)
end;
rmDir (DirName)
end;
Dosya kopyalama
Aşağıdaki kodu içeren unitin Uses listesine "LZExpand"eklenmelidir.
var
SourceHandle, DestHandle: Integer;
SName,DName: String;
begin
SourceHandle := FileOpen(SName,0);
DestHandle := FileCreate(DName);
LZCopy(SourceHandle,DestHandle);
FileClose(SourceHandle);
FileClose(DestHandle);
End;
Başka bir kopyalama yöntemi;
function FileCopy(source,dest: String): Boolean;
var
fSrc,fDst,len: Integer;
size: Longint;
buffer: packed array [0..2047] of Byte;
begin
Result := False;
if source <> dest then begin
fSrc := FileOpen(source,fmOpenRead);
if fSrc >= 0 then begin
size := FileSeek(fSrc,0,2);
FileSeek(fSrc,0,0);
fDst := FileCreate(dest);
if fDst >= 0 then begin
while size > 0 do begin
len := FileRead(fSrc,buffer,sizeof(buffer));
FileWrite(fDst,buffer,len);
size := size - len;
end;
FileSetDate(fDst,FileGetDate(fSrc));
FileClose(fDst);
FileSetAttr(dest,FileGetAttr(source));
Result := True;
end;
FileClose(fSrc);
end;
end;
end;
İkili dosyadan okuma
var
f: File;
c: Char;
begin
AssignFile(f, 'Dosyaadi.bin');
Reset(f, 1);
BlockRead(f, c, sizeof(c));
CloseFile(f);
end;
Yukarıdaki kod her seferinde bir karakter okur. Disk erişimi yavaş bir işlemdir. Bu nedenle bir mecburiyet yoksa, her seferinde 1 karakter yerine daha fazlası okunmalıdır.
Bir dosyanın salt okunur olarak açılması
Assignfile satırından sonra dosya açma modu belirtilmelidir.
AssignFile(F, FileName);
FileMode := 0; ( Salt okunur }
Reset(F);
CloseFile(F);
Satır sonu karakterinin Ascii kodu nedir?
Control-Z, veya 26 numaralı ASCII karakteri
Disk seri numarası ve etiketinin okunması
unit diskinfo;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
diskinfostructure=record
DiskEtiketi:string;
DiskSeriNo :string;
end;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
f:system.text;
blg:diskinfostructure;
implementation
{$R *.DFM}
Function WinExecute32(
FileName : String;
Visibility : integer):integer;
var
zAppName:array[0..512] of char;
zCurDir:array[0..255] of char;
WorkDir:String;
StartupInfo:TStartupInfo;
ProcessInfo:TProcessInformation;
begin
StrPCopy(zAppName,FileName);
GetDir(0,WorkDir);
StrPCopy(zCurDir,WorkDir);
FillChar(StartupInfo,Sizeof(StartupInfo),#0);
StartupInfo.cb := Sizeof(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not CreateProcess(nil,
zAppName,
nil,
nil,
false,
CREATE_NEW_CONSOLE or
NORMAL_PRIORITY_CLASS,
nil,
nil,
StartupInfo,
ProcessInfo) then Result := -1
else
begin
WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess,Result);
end;
end;
function disk(dsk:char;var bilgi:diskinfostructure):boolean;
var
row:array[1..50] of string;
c,i:integer;
vollabel,serial:string;
begin
assignfile(f,'c:\dir.bat');
rewrite(f);
writeln(f,'dir '+dsk+':\*.zzzz> c:\dir.txt');
closefile(f);
winexecute32('c:\dir.bat',0);
assignfile(f,'c:\dir.txt');
reset(f);
i:=1;
while not eof(f) do
begin
readln(f,row[i]);
inc(i,1);
end;
closefile(f);
if pos('is',row[2])>0 then
bilgi.DiskEtiketi:=copy(row[2],pos('is',row[2])+2,11)
else bilgi.DiskEtiketi:='Disk etiketi yok';
bilgi.DiskSeriNo:= copy(row[3],pos('is',row[3])+2,15);
deletefile('c:\dir.bat');
deletefile('c:\dir.txt');
result:=true;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
disk('c',blg);
showmessage(blg.DiskEtiketi);
showmessage(blg.DiskSeriNo);
end;
end.
Disk seri numarasına erişimin başka bir yolu..
unit diskvol;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function GetDiskVolSerialID(
cDriveName : char ) : DWord;
var
dwTemp1,
dwTemp2 : DWord;
begin
GetVolumeInformation(
PChar( cDriveName + ':\' ),
Nil,
0,
@Result,
dwTemp2,
dwTemp2,
Nil,
0
);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
showmessage(inttostr(GetDiskVolSerialID('C')))
end;
end.
Disk bilgilerini elde etmenin bir diğer yolu ise;
type
VolInf=record
Etiket:string;
serino:string;
tip:string;
disk_Tip:string;
bos_yer:string;
Top_Yer:string;
end;
function VolInfo(var diskinfos:volinf;disk:char):boolean;
type
TDrvType = (dtNotDetermined, dtNonExistent, dtRemoveable,
dtFixed, dtRemote, dtCDROM, dtRamDrive);
var
//Disk bigisi kayıtı
nVNameSer : PDWORD;
drv : String;
pVolName : PChar;
FSSysFlags,
maxCmpLen : DWord;
I : Integer;
pFSBuf : PChar;
dType : TDrvType;
SectPerCls,
BytesPerCls,
FreeCls,
TotCls : DWord;
begin
//Değişkenleri sıfırla
drv := disk + ':\';
GetMem(pVolName, MAX_PATH);
GetMem(pFSBuf, MAX_PATH);
GetMem(nVNameSer, MAX_PATH);
//Disk Volume bilgisini al
GetVolumeInformation(PChar(drv), pVolName, MAX_PATH, nVNameSer, maxCmpLen, FSSysFlags, pFSBuf, MAX_PATH);
//Sistem uzun dosya isimlerini destekliyormu?
if (maxCmpLen > 8.3) then
diskinfos.Etiket:= StrPas(pVolName);
diskinfos.serino:=IntToStr(nVNameSer^);
diskinfos.tip:=StrPas(pFSBuf);//dosyasistemi
//Sürücü tipi bilgilerini al
dType := TDrvType(GetDriveType(PChar(drv)));
case dType of
dtNotDetermined : diskinfos.disk_Tip := 'Tespit edilemedi';
dtNonExistent : diskinfos.disk_Tip := 'Mevcut değil';
dtRemoveable : diskinfos.disk_Tip := 'Portatif disk (Floppy)';
dtFixed : diskinfos.disk_Tip := 'Sabit disk';
dtRemote : diskinfos.disk_Tip := 'Uzak veya ağ sürücüsü';
dtCDROM : diskinfos.disk_Tip := 'CD-ROM sürücü';
dtRamDrive : diskinfos.disk_Tip := 'RAM sürücü';
end;
//Diskteki toplam ve boş alan bilgisini al (MB)
GetDiskFreeSpace(PChar(drv), SectPerCls, BytesPerCls, FreeCls, TotCls);
diskinfos.bos_yer:=FormatFloat('0.00', (SectPerCls * BytesPerCls * FreeCls)/1000000) + ' MB';
diskinfos.Top_Yer:= FormatFloat('0.00', (SectPerCls * BytesPerCls * TotCls)/1000000) + ' MB';
//Hafızayı temizle
FreeMem(pVolName, MAX_PATH);
FreeMem(pFSBuf, MAX_PATH);
FreeMem(nVNameSer, MAX_PATH);
end;
Bir dosyanın tarih ve saat bilgisinin alınması
procedure TForm1.Button1Click(Sender: TObject);
var
TheFileDate: string;
Fhandle: integer;
begin
FHandle := FileOpen('C:\COMMAND.COM', 0);
Try
TheFileDate :=
DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
finally
FileClose(FHandle);
end;
SHOWMESSAGE(THEFILEDATE);
end;
Bir klasörün özelliğinin değiştirilmesi
Aşağıdaki kod örneğinde, bir klasörün "Hidden" özelliği değiştirilmektedir.
Function DirectoryHide(Const FileString : String): Boolean;
Var
Attributes : Integer;
Begin
Result := False;
Try
If Not DirectoryExists(FileString) Then Exit;
Attributes := faDirectory + faHidden + faSysFile;
FileSetAttr(FileString,Attributes);
Result := True;
Except
End;
End;
---
Function DirectoryUnHide(Const FileString : String): Boolean;
Var
Attributes : Integer;
Begin
Result := False;
Try
If Not DirectoryExists(FileString) Then Exit;
Attributes := faDirectory;
FileSetAttr(FileString,Attributes);
Result := True;
Except
End;
End;
Dosyanın sürüklenip bırakılması
Fare ile sürüklenerek, aşağıdaki unite bağlı form üzerine dosya bırakıldığında, bırakılan dosyanın dizini ve adı tespit edilmektedir.
unit dragfile;
interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs;
type
TForm2 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure AcceptFiles( var msg : TMessage );
message WM_DROPFILES;
end;
var
Form2: TForm2;
implementation
uses
ShellAPI;
{$R *.DFM}
procedure TForm2.AcceptFiles( var msg : TMessage );
const
cnMaxFileNameLen = 255;
var
i,
nCount : integer;
acFileName : array [0..cnMaxFileNameLen] of char;
begin
nCount := DragQueryFile( msg.WParam,
$FFFFFFFF,
acFileName,
cnMaxFileNameLen );
for i := 0 to nCount-1 do
begin
DragQueryFile( msg.WParam, i,
acFileName, cnMaxFileNameLen );
MessageBox( Handle, acFileName, '', MB_OK );
end;
DragFinish( msg.WParam );
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
DragAcceptFiles( Handle, True );
end;
end.
Windows geçici klasörünün bulunması
Windows 95 ve NT işletim sistemlerinde, geçici dosyalar için kullanılan, genellikle "TEMP" isimli bir klasör vardır. Fakat bazen kullanıcılar bu dizinin adını veya yerini değiştirirler. Aşağıdaki fonksiyon, geçici dizini tespit eder.
function GetTempDirectory: String;
var
TempDir: array[0..255] of Char;
begin
GetTempPath(255, @TempDir);
Result := StrPas(TempDir);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
showmessage(gettempdirectory);
end;
Windows sistem dizininin bulunması
Var
SysDir: PChar;
Size: Word;
SysDirInString : String[144];
Begin
SysDir := '';
GetSystemDirectory(SysDir, Size);
SysDirInString := StrPas(SysDir);
Canvas.TextOut(10, 10, SysDirInString);
end;
Dosya yaratılma tarihi
Bu fonksiyon, dosyanın yaratıldığı tarihi döndürür.
Function File_GetCreationDate(FileName : String): TDateTime;
var
SearchRec : TSearchRec;
DT : TFileTime;
ST : TSystemTime;
begin
Result := 0;
If Not FileExists(FileName) Then Exit;
Try
SysUtils.FindFirst(FileName, faAnyFile, SearchRec);
Try
FileTimeToLocalFileTime(SearchRec.FindData.ftCreationTime,DT);
FileTimeToSystemTime(DT, ST);
Result := SystemTimeToDateTime(ST);
Finally
SysUtils.FindClose(SearchRec);
End;
Except
Result := 0;
End;
end;
Dosyanın son kullanıldığı tarih
Bu fonksiyon, dosyanın, son olarak kullanıldığı tarihi döndürür.
Function File_GetLastAccessDate(FileName : String): TDateTime;
var
SearchRec : TSearchRec;
DT : TFileTime;
ST : TSystemTime;
begin
Result := 0;
If Not FileExists(FileName) Then Exit;
Try
SysUtils.FindFirst(FileName, faAnyFile, SearchRec);
Try
FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT);
FileTimeToSystemTime(DT, ST);
Result := SystemTimeToDateTime(ST);
Finally
SysUtils.FindClose(SearchRec);
End;
Except
Result := 0;
End;
end;
Dosyanın son değiştirildiği tarih
Bu fonksiyon, FileName parametresi ile gönderilen dosyanın, son olarak değiştirildiği tarihi bulmaya yarar.
Function File_GetLastModifiedDate(FileName : String): TDateTime;
var
SearchRec : TSearchRec;
DT : TFileTime;
ST : TSystemTime;
begin
Result := 0;
If Not FileExists(FileName) Then Exit;
Try
SysUtils.FindFirst(FileName, faAnyFile, SearchRec);
Try
FileTimeToLocalFileTime(SearchRec.FindData.ftLastWriteTime,DT);
FileTimeToSystemTime(DT, ST);
Result := SystemTimeToDateTime(ST);
Finally
SysUtils.FindClose(SearchRec);
End;
Except
Result := 0;
End;
end;
Dizin boşmu?
DirName parametresi ile gönderilen dizinin boş olup olmadığını kontrol etmeye yarayan bir fonksiyon.
Function IsDirEmpty(DirName: String): Boolean;
Begin
If IsDir(DirName) Then
Begin
If IsFile(DirName+'\*.*') Then
Begin
Result := False;
End
Else
Begin
Result := True;
End;
End
Else
Begin
Result := False;
End;
End;
Dosya uzantısı hangi programla bağlantılı?
Bir dosyanın uzantısına bakarak, hangi program tarafından çalıştırılacağının bulunması için aşağıdaki kod örneği kullanılabilir.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
const
BufferSize = {$IFDEF Win32} 540 {$ELSE} 80 {$ENDIF};
var
Buffer : PChar;
StringPosition : PChar;
ReturnedData: Longint;
begin
Buffer := StrAlloc(BufferSize);
try
{ get the first entry, don't bother about the version !}
ReturnedData := BufferSize;
StrPCopy(Buffer, '.pas');
RegQueryValue(hKey_Classes_Root, Buffer, Buffer, ReturnedData);
if StrLen(Buffer) > 0 then
begin
showmessage(strpas(buffer));
end;
except
showmessage('bulunamadı');
end;
end;
end.
Geri dönüşüm kutusuna gönder.
Bir dosyayı, geri dönüşüm kutusuna göndererek silmek için ;
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
ShellApi;
function DF(sFileName : string ) : boolean;
var
fos : TSHFileOpStruct;
begin
FillChar( fos, SizeOf( fos ), 0 );
with fos do
begin
Wnd := application.handle;
wFunc := FO_DELETE;
pFrom := PChar( sFileName );
fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;
end;
Result := ( 0 = ShFileOperation( fos ) );
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
df('c:\"WP.txt');
end;
end.
6. Genel
Bu bölümde, diğer başlıklar altında yer almayan püf noktaları ve kod örnekleri yer almaktadır.
Karakter dizisi karşılaştırma
unit matchstring;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
CheckBox1: TCheckBox;
Edit1: TEdit;
Edit2: TEdit;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
function MatchStrings(source, pattern: String): Boolean;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function tform1.MatchStrings(source, pattern: String): Boolean;
var
pSource: Array [0..255] of Char;
pPattern: Array [0..255] of Char;
function MatchPattern(element, pattern: PChar): Boolean;
function IsPatternWild(pattern: PChar): Boolean;
var
t: Integer;
begin
Result := StrScan(pattern,'*') <> nil;
if not Result then Result := StrScan(pattern,'?') <> nil;
end;
begin
if 0 = StrComp(pattern,'*') then
Result := True
else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then
Result := False
else if element^ = Chr(0) then
Result := True
else begin
case pattern^ of
'*': if MatchPattern(element,@pattern[1]) then
Result := True
else
Result := MatchPattern(@element[1],pattern);
'?': Result := MatchPattern(@element[1],@pattern[1]);
else
if element^ = pattern^ then
Result := MatchPattern(@element[1],@pattern[1])
else
Result := False;
end;
end;
end;
begin
StrPCopy(pSource,source);
StrPCopy(pPattern,pattern);
Result := MatchPattern(pSource,pPattern);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
checkbox1.checked:=matchstrings(edit1.text,edit2.text);
end;
end.
Yüklenmiş DLL dosyalarının hafızadan atılması
Kullanılmayan DLL'lerin hafızada boşuna yer işgal etmemesi için hafızadan atılması gerekebilir. Aşağıdaki kod örneğinde bu işlemin yapılması gösterilmektedir. EditDLLName isimli 1 Tedit, 1 Tamam ve 1 adet de Kapat butonu form üzerine yerleştirilmiştir. Tamam butonunun OnClick davranışına yazılan kod aşağıdadır.
procedure TForm1.TamamBtnClick(Sender: TObject); var hDLL: THandle;
aName : array[0..10] of char;
FoundDLL : Boolean;
begin
if EditDLLName.Text = '' then
begin
MessageDlg('Çıkarılacak DLL dosyasının adını yazınız.!',mtInformation,[mbOk],0);
exit;
end;
StrPCopy(aName, EditDLLName.Text);
FoundDLL := false;
repeat
hDLL := GetModuleHandle(aName);
if hDLL = 0 then
break;
FoundDLL := true;
FreeLibrary(hDLL);
until false;
if FoundDLL then
MessageDlg('Tamam!',mtInformation,[mbOk],0)
else
MessageDlg('DLL Bulunamadı!',mtInformation,[mbOk],0);
EditDLLName.Text := '';
end;
Bir DOS komutunun kullanılması
Windows 95 ortamındayken, bir DOS komutunun çalıştırılması için gereken yordam şudur.
procedure doskomutu(komut:string;mesajver:boolean);
var
Startupinfo:TStartupinfo;
ProcessInfo:TProcessInformation;
begin
if terminateprocess(processinfo.hProcess,0)=NULL then
begin
if mesajver then showmessage('Devam eden işlem iptal edilemedi');
exit;
end;
FillChar(StartupInfo,Sizeof(StartupInfo),#0);
StartupInfo.cb := Sizeof(StartupInfo);
StartupInfo.wShowWindow := SW_HIDE;
StartupInfo.dwFlags:=STARTF_USESHOWWINDOW;
if not CreateProcess(nil,
Pchar('c:\command.com /c '+komut),
nil,
nil,
true,
NORMAL_PRIORITY_CLASS,
nil,
nil,
StartupInfo,
ProcessInfo) then
begin
if mesajver then
ShowMessage('İşlem gerçekleştirilemedi')
end
else
begin
if mesajver then ShowMessage('İşlem tamam')
end;
end;
Bu yordamın kullanımı;
procedure TForm1.Button1Click(Sender: TObject);
begin
doskomutu('copy c:\autoexec.bat a:\autoexec.dat',false);
end;
TEdit metninin, OnChange olayında değiştirilmesi
Eğer, bir Tedit bileşenindeki metni, aynı bileşenin OnChange olayında değiştirmeye kalkarsanız, yığın (Stack) dolana kadar sürecek bir zincirleme reaksiyon yaratırsınız. Bu işlemi yapabilmek için, OnChange olay yordamına girildiğinde, önce OnChange olayı boşaltılmalı, işlem bitince yeniden eski haline getirilmelidir.
procedure Edit1Change(Sender : TObject);
begin
Edit1.OnChange := NIL;
if Edit1.Text = 'Some Text' then
Edit1.Text := 'New Text';
Edit1.OnChange := Edit1Change;
end;
TMemo bileşeninde, imleç hangi satırda?
Bir Tmemo bileşeninde, imlecin hangi satırda olduğunu anlamak için;
With Memo1 do begin
Line := Perform(EM_LINEFROMCHAR,SelStart, 0);
Column := SelStart - Perform(EM_LINEINDEX, Line, 0);
end;
Ulusal ayarlar
Başlangıçta, Delphi bütün Tarih/Saat ayarlarını Kontrol panelde belirtilen bölgesel ayarlardan alarak kullanır. Bu durum, özellikle tarih alanlarına değer girildiğinde, hatalara neden olabilir. Bu sorunun çözümü için, Delphi içerisinde tanımlanmış ve bu tür bilgileri taşıyan değişkenleri, isteğinizi karşılayacak şekilde değiştirebilirsiniz.
DecimalSeparator := '.';
ShortDateFormat := 'mm/dd/yy';
TeditBox bileşenindeki metnin ilk karakterinin, büyük harfe çevirilmesi
TeditBox bileşenindeki metnin ilk karakterinin, büyük harfe çevirilmesi için aşağıdaki kod kullanılabilir.
procedure TForm1.Edit1Change(Sender: TObject);
var
OldStart : Integer;
begin
With Edit1 do
if Text <> '' then
begin
OnChange := NIL;
OldStart := SelStart;
Text := UpperCase(Copy(Text,1,1))+
LowerCase(Copy(Text,2,Length(Text)));
SelStart := OldStart;
OnChange := Edit1Change;
end;
end;
Windows'un kapanma anının tespiti
Windows'un kapanma anının yakalanabilmesi için, Windows tarafından kapanmadan önce yayınlanan, WM_EndSession mesajı yakalanmalıdır.
Mesaj yakalama yordamı, uygulama ana form sınıfının, Private bölümünde şu şekilde tanımlanır.
procedure WMEndSession(var Msg : TWMEndSession); message WM_ENDSESSION;
Mesaj yakalama yordamının kendisi ise, Implementation bölümünde aşağıdaki gibi yaratılır.
procedure TForm1.WMEndSession(var Msg : TWMEndSession);
begin
if Msg.EndSession = TRUE then
ShowMessage('Windows kapatılıyor. ');
inherited;
end;
veya
procedure TForm1.WMQueryEndSession(var Msg : TWMQueryEndSession);
begin
if MessageDlg('Windows kapansınmı ?', mtConfirmation, [mbYes,mbNo], 0) = mrNo then
Msg.Result := 0
else
Msg.Result := 1;
end;
Windowsun kapandığını tespit eden bir bileşen kodu aşağıdadır.
unit winshut;
interface
uses
Messages, SysUtils, Classes, Forms, Windows;
type
TkapanmaOlayi = procedure (Sender: TObject; var TamamKapat: boolean) of object;
type
TSezonuKapat = class(TComponent)
private
FUYG: THandle;
FParent: THandle;
FESKIWINYORD: pointer;
FYeniPencereYordami: pointer;
KAPANIRKEN: TkapanmaOlayi;
TamamKapat: boolean;
procedure YeniPencereYordami(var MESAJ: TMessage);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Loaded; override;
published
property WINKAPANIS: TkapanmaOlayi read KAPANIRKEN write KAPANIRKEN;
end;
procedure Register;
implementation
constructor TSezonuKapat.Create (AOwner : TComponent);
begin
inherited Create(AOwner);
TamamKapat := TRUE;
FUYG := Application.Handle;
FParent := (AOwner as TForm).Handle;
FYeniPencereYordami := MakeObjectInstance(YeniPencereYordami);
end;
destructor TSezonuKapat.Destroy;
begin
SetWindowLong(FUYG, GWL_WndProc, longint(FESKIWINYORD));
FreeObjectInstance(FYeniPencereYordami);
inherited Destroy;
end;
procedure TSezonuKapat.Loaded;
begin
inherited Loaded;
FESKIWINYORD := pointer(SetWindowLong(FUYG, GWL_WndProc,longint(FYeniPencereYordami)));
end;
procedure TSezonuKapat.YeniPencereYordami(var MESAJ: TMessage);
begin
with MESAJ do
begin
if (Msg=WM_QUERYENDSESSION) then
begin
if Assigned(KAPANIRKEN) then KAPANIRKEN(Self,TamamKapat);
if TamamKapat then
Result := CallWindowProc(FESKIWINYORD, FUYG, Msg, wParam,lParam)
else
Result := 0;
end
else
Result := CallWindowProc(FESKIWINYORD, FUYG, Msg, wParam,lParam);
end;
end;
procedure Register;
begin
RegisterComponents('Kitap', [TSezonuKapat]);
end;
end.
Bir memo veya RichEdit bileşeninde, imlecin istenen yere gönderilmesi
With Memo1 do
SelStart := Perform(EM_LINEINDEX, Line, 0);
Windows çevirmeli ağ bağlantı penceresinin çağırılması
procedure TForm1.Button1Click(Sender: TObject);
begin
winexec(PChar('rundll32.exe rnaui.dll,RnaDial '+Edit1.Text),sw_show);
end;
Otomatik e-mail
//uses satırına shellapi eklenmeli
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute(Handle,'open','mailto:fdemirel@kkk.tsk.mil.tr','','',sw_Normal);
end;
Monitörün kapatılması/Açılması
Kapatılması;
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);
timer1.enabled:=true;
end;
açılması için;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);
timer1.enabled:=false;
end;
Windows'un kapatılması/Yeniden başlatılması
Kapatılması;
procedure TMainForm.RestartWindowsBtnClick(Sender: TObject);
begin
if not ExitWindows(EW_RestartWindows, 0) then
ShowMessage('Bir uyulama kapanmayı reddetti');
end;
Yeniden başlatılması;
procedure TMainForm.RebootSystemBtnClick(Sender: TObject);
begin
if not ExitWindows(EW_RebootSystem, 0) then
ShowMessage(Bir uyulama kapanmayı reddetti ');
end;
Sistemde ses kartı varmı?
Winmm.Dll de bulunan waveOutGetNumDevs fonksiyonu kullanılarak, sistemde ses kartı olup olmadığı anlaşılabilir. Önce interface bölümünde fonksiyon tanımlanmalıdır.
function SoundCardPresent : longint; stdcall; external 'winmm.dll' name 'waveOutGetNumDevs';
Kullanımı;
If SoundCardPresent = 0 then
Showmessage('Ses kartı yok');
Programın arka planda çalıştırılması
Program çalıştığında, hiç bir yerde görünmediği halde, ikonunu Windows görev çubuğuna yerleştirecektir. Üzerinde sağ fare tuşuna basılarak açılacak menü ile görünür hale getirilebilir.
Unit1.dfm;
unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls, ShellAPI, Menus;
const WM_MINIMALIZE = WM_USER + 1
type
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
Show1: TMenuItem;
Hide1: TMenuItem;
Quit1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Show1Click(Sender: TObject);
procedure Hide1Click(Sender: TObject);
procedure Quit1Click(Sender: TObject);
private
FIconData : TNotifyIconData;
public
procedure WMMinimalize(var Message : TMessage); message WM_MINIMALIZE;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var i : Integer;
begin
with FIconData do
begin
cbSize := SizeOf(FIconData);
Wnd := Self.Handle;
uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
hIcon := Application.Icon.Handle;
uCallbackMessage := WM_MINIMALIZE; szTip := 'My own application';
end;
Shell_NotifyIcon(NIM_ADD, @FIconData);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, @FIconData);
end;
procedure TForm1.WMMinimalize(var Message : TMessage);
var p : TPoint;
begin
case Message.LParam of
WM_RBUTTONUP: begin
GetCursorPos(p);
PopupMenu1.Popup(p.x, p.y);
end;
end;
end;
procedure TForm1.Show1Click(Sender: TObject);
begin
Form1.Visible := TRUE;
ShowWindow(Application.Handle, SW_HIDE);
end;
procedure TForm1.Hide1Click(Sender: TObject);
begin
Self.Visible := FALSE;
end;
procedure TForm1.Quit1Click(Sender: TObject);
begin
Application.Terminate;
end;
end.
Project1.dpr;
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.ShowMainForm := FALSE;
Application.Run;
end.
Windows görev çubuğunun gizlenmesi/Gösterilmesi
Gizlenmesi;
procedure TForm1.Button1Click(Sender: TObject);
var
MyTaskbar:Hwnd;
begin
MyTaskBar:= FindWindow('Shell_TrayWnd', nil);
ShowWindow(MyTaskBar, SW_HIDE);
end;
Gösterilmesi
procedure TForm1.Button2Click(Sender: TObject);
var
MyTaskbar:Hwnd;
begin
MyTaskBar:= FindWindow('Shell_TrayWnd', nil);
ShowWindow(MyTaskBar, SW_SHOW);
end;
Çalışan programın, Görev çubuğu üzerinden kaldırılması
program Project1;
uses
Forms,windows,
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
var
es:integer;
begin
Application.Initialize;
ES := GetWindowLong(Application.Handle, GWL_EXSTYLE);
ES := ES or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW;
SetWindowLong(Application.Handle, GWL_EXSTYLE, ES);
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
OCX'kullanımı
Programda OCX örneğin THTML kullanıldığında, programı başka bir makinede çalıştırmak, problem olabilir. Bunun sebebi, OCX'lerin, çalışabilmeleri için Sistem kayıtları veri tabanına kayıtlı olmalarının gerekmesidir. Bu işlem Regsvr32.exe kullanılarak veya programın kendi içerisinden yapılabilir. Başka bir problem nedeni ise OCX kontrolünün birden fazla dosyadan oluşması ihtimalidir. Bunların tümü diğer makineye taşınmalıdır.
OCX için hangi dosyaların gerekli olduğu QuickView programı kullanılarak tespit edilebilir.Aşağıda, kullanılan OCX'leri diğer makineye kaydettiren bir yordam yeralmaktadır.
function CheckOCX:Boolean;
var Reg:TRegistry;
begin
Reg:=TRegistry.Create;
try
Reg.RootKey:=HKEY_CLASSES_ROOT;
// Kontrolün UID bilgisi windows sistem kayıtları veri
//tabanından alınmaktadır.
Result:=Reg.OpenKey('CLSID\{B7FC3550-8CE7-11CF-9754-00AA00C00908}',False);
if Result then Reg.CloseKey;
finally
Reg.Free;
end;
end;
procedure RegisterOCX;
var Lib:THandle;
S:String;
P:TProcedure;
begin
OleInitialize(nil);
try
S:=ExtractFilePath(Application.ExeName)+'HTML.OCX';
Lib:=LoadLibrary(PChar(S));
if Lib<HINSTANCE_ERROR then
raise Exception.CreateFmt('Cannot initialize library %s. Internal Windows error %d',[S,Lib]);
try
P:=GetProcAddress(Lib,'DllRegisterServer');
if not Assigned(P) then raise Exception.Create('Cannot find procedure DllRegisterServer');
P;
finally
FreeLibrary(Lib);
end;
finally
OleUninitialize;
end;
end;
procedure Uninstall;
var Lib:THandle;
S:String;
P:TProcedure;
begin
S:=ExtractFilePath(Application.ExeName)+'HTML.OCX';
Lib:=LoadLibrary(PChar(S));
if Lib<HINSTANCE_ERROR then
raise Exception.CreateFmt('Cannot initialize library %s. Internal Windows error %d',[S,Lib]);
try
P:=GetProcAddress(Lib,'DllUnregisterServer');
if not Assigned(P) then raise Exception.Create('Cannot find procedure DllUnregisterServer');
P;
finally
FreeLibrary(Lib);
end;
end;
Bazen, bu kayıtlar diğer makinede olduğu halde dosyalardan biri veya birkaçı eksik olabilir.
Ekran çözünürlüğündeki değişikliklerin tespiti
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TForm1 = class(TForm)
private
{ Private declarations }
public
{ Public declarations }
procedure WMDisplayChange( var msg : TWMDisplayChange );message wm_DisplayChange;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure tform1.WMDisplayChange( var msg : TWMDisplayChange );
begin
showmessage('Renk=2 üzeri '+inttostr(msg.BitsPerPixel)+
' En='+inttostr(msg.width)+
' Boy='+inttostr(msg.height))
end;
end.
Pano Görüntüleme
Panoya kopyalanan metnin, görüntülenmesi
unit ClipboardViewer;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FNextViewerHandle : THandle;
procedure WMDrawClipboard (var message : TMessage);
message WM_DRAWCLIPBOARD;
procedure WMChangeCBCHain (var message : TMessage);
message WM_CHANGECBCHAIN;
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
FNextViewerHandle := SetClipboardViewer(Handle);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
ChangeClipboardChain(Handle, FNextViewerHandle);
end;
procedure TForm1.WMDrawClipboard (var message : TMessage);
begin
message.Result := SendMessage(WM_DRAWCLIPBOARD, FNextViewerHandle, 0, 0);
memo1.lines.clear;
memo1.PasteFromClipboard
end;
procedure TForm1.WMChangeCBCHain (var message : TMessage);
begin
if message.wParam = FNextViewerHandle then begin
FNextViewerHandle := message.lParam;
message.Result := 0;
end else begin
message.Result := SendMessage(FNextViewerHandle, WM_CHANGECBCHAIN,
message.wParam, message.lParam);
end;
end;
end.
CPU bilgileri
Bilgisayardaki mikro işlemcinin tipinin ve üreticisinin tepit edilmesi için, aşağıdaki unit kullanılabilir.
unit CpuInfo;
interface
type
TFeatures = record
case integer of
0: (RegEAX,
RegEBX,
RegEDX,
RegECX:integer);
1 : (I :array [0..3] of integer);
2 : (C :array [0..15] of char);
3 : (B :array [0..15] of byte)
end;
const
{$IFNDEF WIN32}
i8086 = 1;
i80286 = 2;
i80386 = 3;
{$ENDIF}
i80486=4;
Chip486=4;
iPentium= 5;
Chip586=5;
iPentiumPro=6;
Chip686=6;
Intel='GenuineIntel';
AMD='AuthenticAMD';
var
CpuType:byte = 0;
VendorId:string [12]= '';
Features:TFeatures
procedure LoadFeatures (I : integer);
implementation
{$O-}
const
CpuId = $0a20f;
var
CpuIdFlag:boolean = false; MaxCPUId:integer;
procedure GetF;
asm
dw CpuId
mov [Features.RegEAX], eax
mov [Features.RegEBX], ebx
mov [Features.RegECX], ecx
mov [Features.RegEDX], edx
end;
procedure ClearF;
asm
mov edi, offset Features
xor eax, eax
mov ecx, eax
mov cl, 4
cld
rep stosd
end;
procedure CheckOutCpu;
asm
{$IFNDEF WIN32}
pushf
pop ax
mov cx, ax
and ax, 0fffh
push ax
popf
pushf
pop ax
and ax, 0f000h
cmp ax, 0f000h
mov [CPUType], 1
je @@2
or cx, 0f000h
push cx
popf
push
pop ax
and ax, 0f000h
mov [CPUType], 2
jz @@2
pushfd
pop eax
mov ecx, eax
xor eax, 40000h
push eax
popfd
pushfd
pop eax
xor eax, ecx
mov [CPUType], 3
jz @@2
push ecx
popfd
{$ENDIF}
mov [CPUType], 4
mov eax, ecx
xor eax, 200000h
push eax
popfd
pushfd
pop eax
xor eax, ecx
je @@2
mov [CPUIdFlag], 1
push ebx
mov eax,0
dw CpuId
mov [MaxCPUId], eax
mov [byte ptr VendorId], 12
mov [dword ptr VendorId+1], ebx
mov [dword ptr VendorId+5], edx
mov [dword ptr VendorId+9], ecx
callClearF
mov eax, 1
cal GetF
shr eax, 8
and eax, 0fh
mov [CPUType], al
@@1: pop ebx
@@2:
end;
procedure LoadFeatures (I : integer);
asm
call ClearF
cmp [CpuIdFlag], 0
je @@1
mov eax, [I]
cmp [MaxCpuId], eax
jl @@1
call GetF
@@1:
end;
initialization
CheckOutCPU;
end.
CPU tipi ile ilgili bilgiler, "Cputype", ve "vendorid" değişkenlerine yüklenmektedirler.;
Aynı maksatla kullanılabilecek başka bir kod örneği de şudur.
unit cpuinfo;
interface
uses
Windows, SysUtils;
type
Freq_info = Record
Raw_Freq: Cardinal; // Ham CPU frekansı MHz.
Norm_Freq: Cardinal; // Ortalama CPU frekansı MHz.
In_Cycles: Cardinal; // Sistem saati hizi
Ex_Ticks: Cardinal; // Test süresi
end;
TCpuInfo = Record
VendorIDString: String;
Manufacturer: String;
CPU_Name: String;
PType: Byte;
Family: Byte;
Model: Byte;
Stepping: Byte;
Features: Cardinal;
MMX: Boolean;
Frequency_Info: Freq_Info;
IDFDIVOK: Boolean;
end;
Const
InfoStrings: Array[0..1] of String = ('FDIV instruction is Flawed',
'FDIV instruction is OK');
Const
// CPU değerlerinin tespitinde kullanılacak sabitler
// Örnek IF (Features and FPU_FLAG = FPU_FLAG) ise CPU'da Floating-Point birim vardır.
FPU_FLAG = $00000001;
VME_FLAG = $00000002;
DE_FLAG = $00000004;
PSE_FLAG = $00000008;
TSC_FLAG = $00000010;
MSR_FLAG = $00000020;
PAE_FLAG = $00000040;
MCE_FLAG = $00000080;
CX8_FLAG = $00000100;
APIC_FLAG = $00000200;
BIT_10 = $00000400;
SEP_FLAG = $00000800;
MTRR_FLAG = $00001000;
PGE_FLAG = $00002000;
MCA_FLAG = $00004000;
CMOV_FLAG = $00008000;
BIT_16 = $00010000;
BIT_17 = $00020000;
BIT_18 = $00040000;
BIT_19 = $00080000;
BIT_20 = $00100000;
BIT_21 = $00200000;
BIT_22 = $00400000;
MMX_FLAG = $00800000;
BIT_24 = $01000000;
BIT_25 = $02000000;
BIT_26 = $04000000;
BIT_27 = $08000000;
BIT_28 = $10000000;
BIT_29 = $20000000;
BIT_30 = $40000000;
BIT_31 = $80000000;
Procedure GetCPUInfo(Var CPUInfo: TCpuInfo);
Function GetRDTSCCpuSpeed: Freq_Info;
Function CPUID: TCpuInfo;
Function TestFDIVInstruction: Boolean;
implementation
Procedure GetCPUInfo(Var CPUInfo: TCpuInfo);
begin
CPUInfo := CPUID;
CPUInfo.IDFDIVOK := TestFDIVInstruction;
IF (CPUInfo.Features and TSC_FLAG = TSC_FLAG) then
CPUInfo.Frequency_Info := GetRDTSCCpuSpeed;
If (CPUInfo.Features and MMX_FLAG) = MMX_FLAG then
CPUInfo.MMX := True
else
CPUInfo.MMX := False;
end;
Function GetRDTSCCpuSpeed: Freq_Info;
var
Cpu_Speed: Freq_Info;
t0, t1: TLargeInteger;
freq, freq2, freq3, Total: Cardinal;
Total_Cycles, Cycles: Cardinal;
Stamp0, Stamp1: Cardinal;
Total_Ticks, Ticks: Cardinal;
Count_Freq: TLargeInteger;
Tries, IPriority, hThread: Integer;
begin
freq := 0;
freq2 := 0;
freq3 := 0;
tries := 0;
total_cycles := 0;
total_ticks := 0;
Total := 0;
hThread := GetCurrentThread();
if (Not QueryPerformanceFrequency(count_freq)) then
begin
Result := cpu_speed;
end
else
begin
while ((tries < 3 ) or ((tries < 20) and ((abs(3 * freq - total) > 3) or
(abs(3 * freq2-total) > 3) or (abs(3 * freq3-total) > 3)))) do
begin
inc(tries);
freq3 := freq2;
freq2 := freq;
QueryPerformanceCounter(t0);
t1.LowPart := t0.LowPart;
t1.HighPart := t0.HighPart;
iPriority := GetThreadPriority(hThread);
if ( iPriority <> THREAD_PRIORITY_ERROR_RETURN ) then
begin
SetThreadPriority(hThread, THREAD_PRIORITY_TIME_CRITICAL);
end;
while ((t1.LowPart - t0.LowPart) < 50) do
begin
QueryPerformanceCounter(t1);
asm
push eax
push edx
db 0Fh
db 31h
MOV stamp0, EAX
pop edx
pop eax
end;
end;
t0.LowPart := t1.LowPart;
t0.HighPart := t1.HighPart;
while ((t1.LowPart - t0.LowPart) < 1000) do
begin
QueryPerformanceCounter(t1);
asm
push eax
push edx
db 0Fh
db 31h
MOV stamp1, EAX
pop edx
pop eax
end;
end;
if ( iPriority <> THREAD_PRIORITY_ERROR_RETURN ) then
begin
SetThreadPriority(hThread, iPriority);
end;
cycles := stamp1 - stamp0;
ticks := t1.LowPart - t0.LowPart;
ticks := ticks * 100000;
ticks := Round(Ticks / (count_freq.LowPart/10));
total_ticks := Total_Ticks + ticks;
total_cycles := Total_Cycles + cycles;
freq := Round(cycles / ticks);
total := (freq + freq2 + freq3);
end;
freq3 := Round((total_cycles * 10) / total_ticks);
freq2 := Round((total_cycles * 100) / total_ticks);
If (freq2 - (freq3 * 10) >= 6) then
inc(freq3);
cpu_speed.raw_freq := Round(total_cycles / total_ticks);
cpu_speed.norm_freq := cpu_speed.raw_freq;
freq := cpu_speed.raw_freq * 10;
if((freq3 - freq) >= 6) then
inc(cpu_speed.norm_freq);
cpu_speed.ex_ticks := total_ticks;
cpu_speed.in_cycles := total_cycles;
Result := cpu_speed;
end;
end;
Function CPUID: TCpuInfo;
type
regconvert = record
bits0_7: Byte;
bits8_15: Byte;
bits16_23: Byte;
bits24_31: Byte;
end;
var
CPUInfo: TCpuInfo;
TEBX, TEDX, TECX: Cardinal;
TString: String;
VString: String;
temp: regconvert;
begin
asm
MOV [CPUInfo.PType], 0
MOV [CPUInfo.Model], 0
MOV [CPUInfo.Stepping], 0
MOV [CPUInfo.Features], 0
MOV [CPUInfo.Frequency_Info.Raw_Freq], 0
MOV [CPUInfo.Frequency_Info.Norm_Freq], 0
MOV [CPUInfo.Frequency_Info.In_Cycles], 0
MOV [CPUInfo.Frequency_Info.Ex_Ticks], 0
push eax
push ebp
push ebx
push ecx
push edi
push edx
push esi
@@Check_80486:
MOV [CPUInfo.Family], 4
MOV TEBX, 0
MOV TEDX, 0
MOV TECX, 0
PUSHFD
POP EAX
MOV ECX, EAX
XOR EAX, 200000H
PUSH EAX
POPFD
PUSHFD
POP EAX
XOR EAX, ECX
JE @@DONE_CPU_TYPE
@@Has_CPUID_Instruction:
MOV EAX, 0
DB 0FH
DB 0A2H
MOV TEBX, EBX
MOV TEDX, EDX
MOV TECX, ECX
MOV EAX, 1
DB 0FH
DB 0A2H
MOV [CPUInfo.Features], EDX
MOV ECX, EAX
AND EAX, 3000H
SHR EAX, 12
MOV [CPUInfo.PType], AL
MOV EAX, ECX
AND EAX, 0F00H
SHR EAX, 8
MOV [CPUInfo.Family], AL
MOV EAX, ECX
AND EAX, 00F0H
SHR EAX, 4
MOV [CPUInfo.MODEL], AL
MOV EAX, ECX
AND EAX, 000FH
MOV [CPUInfo.Stepping], AL
@@DONE_CPU_TYPE:
pop esi
pop edx
pop edi
pop ecx
pop ebx
pop ebp
pop eax
end;
If (TEBX = 0) and (TEDX = 0) and (TECX = 0) and (CPUInfo.Family = 4) then
begin
CPUInfo.VendorIDString := 'Unknown';
CPUInfo.Manufacturer := 'Unknown';
CPUInfo.CPU_Name := 'Generic 486';
end
else
begin
With regconvert(TEBX) do
begin
TString := CHR(bits0_7) + CHR(bits8_15) + CHR(bits16_23) + CHR(bits24_31);
end;
With regconvert(TEDX) do
begin
TString := TString + CHR(bits0_7) + CHR(bits8_15) + CHR(bits16_23) + CHR(bits24_31);
end;
With regconvert(TECX) do
begin
TString := TString + CHR(bits0_7) + CHR(bits8_15) + CHR(bits16_23) + CHR(bits24_31);
end;
VString := TString;
CPUInfo.VendorIDString := TString;
If (CPUInfo.VendorIDString = 'GenuineIntel') then
begin
CPUInfo.Manufacturer := 'Intel';
Case CPUInfo.Family of
4: Case CPUInfo.Model of
1: CPUInfo.CPU_Name := 'Intel 486DX Processor';
2: CPUInfo.CPU_Name := 'Intel 486SX Processor';
3: CPUInfo.CPU_Name := 'Intel DX2 Processor';
4: CPUInfo.CPU_Name := 'Intel 486 Processor';
5: CPUInfo.CPU_Name := 'Intel SX2 Processor';
7: CPUInfo.CPU_Name := 'Write-Back Enhanced Intel DX2 Processor';
8: CPUInfo.CPU_Name := 'Intel DX4 Processor';
else CPUInfo.CPU_Name := 'Intel 486 Processor';
end;
5: CPUInfo.CPU_Name := 'Pentium';
6: Case CPUInfo.Model of
1: CPUInfo.CPU_Name := 'Pentium Pro';
3: CPUInfo.CPU_Name := 'Pentium II';
else CPUInfo.CPU_Name := PChar(Format('P6 (Model %d)', [CPUInfo.Model]));
end;
else CPUInfo.CPU_Name := Format('P%d', [CPUInfo.Family]);
end;
end
else if (CPUInfo.VendorIDString = 'CyrixInstead') then
begin
CPUInfo.Manufacturer := 'Cyrix';
Case CPUInfo.Family of
5: CPUInfo.CPU_Name := 'Cyrix 6x86';
6: CPUInfo.CPU_Name := 'Cyrix M2';
else CPUInfo.CPU_Name := Format('%dx86', [CPUInfo.Family]);
end;
end
else if (CPUInfo.VendorIDString = 'AuthenticAMD') then
begin
CPUInfo.Manufacturer := 'AMD';
Case CPUInfo.Family of
4: CPUInfo.CPU_Name := 'Am486 or Am5x86';
5: Case CPUInfo.Model of
0: CPUInfo.CPU_Name := 'AMD-K5 (Model 0)';
1: CPUInfo.CPU_Name := 'AMD-K5 (Model 1)';
2: CPUInfo.CPU_Name := 'AMD-K5 (Model 2)';
3: CPUInfo.CPU_Name := 'AMD-K5 (Model 3)';
6: CPUInfo.CPU_Name := 'AMD-K6';
else CPUInfo.CPU_Name := 'Unknown AMD Model';
end;
else CPUInfo.CPU_Name := 'Unknown AMD Chip';
end;
end
else
begin
CPUInfo.VendorIDString := TString;
CPUInfo.Manufacturer := 'Unknown';
CPUInfo.CPU_Name := 'Unknown';
end;
end;
Result := CPUInfo;
end;
Function TestFDIVInstruction: Boolean;
var
TestDividend: Double;
TestDivisor: Double;
TestOne: Double;
ISOK: Boolean;
begin
TestDividend := 4195835.0;
TestDivisor := 3145727.0;
TestOne := 1.0;
asm
PUSH EAX
FLD [TestDividend]
FDIV [TestDivisor]
FMUL [TestDivisor]
FSUBR [TestDividend]
FCOMP [TestOne]
FSTSW AX
SHR EAX, 8
AND EAX, 01H
MOV ISOK, AL
POP EAX
end;
Result := ISOK;
end;
end.
Enter tuşunun Tab yerine kullanılabileceği bir Tedit bileşeni
Enter (Return) tuşuna basıldığında Tab tuşuna basılmış etkisi yaratmak için aşağıdaki kod kullanılabilir.
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if key=#13 then
begin
perform(wm_nextdlgctl,0,0);
key:=#0;
end;
end;
Aşağıdaki bileşen kodu, standart bir Tedit bileşenini, değiştirerek Enter ve Ok tuşlarına tepki verebilecek yeni bir Edit kontrolü haline getirmektedir.
unit Entedit;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TEnterEdit = class(TEdit)
private
protected
procedure KeyPress(var Key: Char); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
public
published
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Kitap', [TEnterEdit]);
end;
procedure TEnterEdit.KeyPress(var Key: Char);
var
MYForm: TcustomForm;
begin
if Key = #13 then
begin
MYForm := GetParentForm( Self );
if not (MYForm = nil ) then
SendMessage(MYForm.Handle, WM_NEXTDLGCTL, 0, 0);
Key := #0;
end;
if Key <> #0 then inherited KeyPress(Key);
end;
procedure TEnterEdit.KeyDown(var Key: Word; Shift: TShiftState);
var
MYForm: TcustomForm;
CtlDir: Word;
begin
if (Key = VK_UP) or (Key = VK_DOWN) then
begin
MYForm := GetParentForm( Self );
if Key = VK_UP then CtlDir := 1
else CtlDir :=0;
if not (MYForm = nil ) then
SendMessage(MYForm.Handle, WM_NEXTDLGCTL, CtlDir, 0);
end
else inherited KeyDown(Key, Shift);
end;
end.
Tarih doğru mu
Function Tarihgecerlimi(DateString: String): Boolean;
Begin
Try
StrToDateTime(DateString);
Result := True;
Except
Result := False;
End;
End;
Ayda kaç gün var?
Function AydakiGunSayisi(DateValue: TDateTime): Integer;
var
yil : Word;
ay : Word;
gün : Word;
yeniyil : Word;
yeniay : Word;
yenigun : Word;
sayacr : Integer;
yenitarih : TDateTime;
Begin
Result := 30;
Try
DecodeDate(DateValue, Yil, ay, gun);
NewDate := EncodeDate(yil, ay, 26);
For sayac := 26 To 32 Do
Begin
yenitarih := NewDate+1;
DecodeDate(yenitarih, yeniyil, yeniay, yenigun);
If MonthNew <> MonthIn Then
Begin
DecodeDate(yenitarih-1, Yeniyil, yeniay, yenigun);
Result := yenigun;
Break;
End;
End;
Except
End;
End;
Geçen Haftanın ilk Günü
Function GecenHaftaninIlkGunu(DateValue: TDateTime): TDateTime;
Begin
Result := HaftaninIlkGunu(DateValue-7);
End;
Sonraki Ayın ilk Günü
Function SonrakiAyinIlkGunu(DateValue: TDateTime): TDateTime;
Begin
Try
Result := AyinSonGunu(DateValue)+1;
Except
Result := DateValue;
End;
End;
Sonraki haftanın ilk günü
Function SonrakiHaftaninIlkGunu(DateValue: TDateTime): TDateTime;
Begin
Result := HaftaninIlkGunu(DateValue+7);
End;
Haftanın ilk günü
Function HaftaninIlkGunu(DateValue: TDateTime): TDateTime;
Begin
Try
Result := DateValue - (DayOfWeek(DateValue)) +1;
Except
Result := 0;
End;
End;
Ayın son günü
Function AyinSonGunu(DateValue: TDateTime): TDateTime;
Var
LastDay : String;
Begin
LastDay := IntToStr(AydakiGunSayisi(DateValue));
Result := StrToDate(
FormatDateTime('mm',DateValue)+
'/'+
LastDay+
'/'+
FormatDateTime('yyyy',DateValue));
End;
Ay
Function Ay(DateValue: TDateTime): Integer;
Var
Year, Month, Day: Word;
Begin
Result := -1;
Try
DecodeDate(DateValue, Year, Month, Day);
Result := Integer(Month);
Except
Result := -1;
End;
End;
Gelecek ay
Function GelecekAy(DateValue: TDateTime): Integer;
Var
Year, Month, Day: Word;
CurMonth : Integer;
NewMonth : Integer;
Begin
Result := -1;
Try
DecodeDate(DateValue, Year, Month, Day);
CurMonth := Integer(Month);
NewMonth := ((CurMonth + 12 + 1) mod 12);
If NewMonth = 0 Then NewMonth := 12;
Result := NewMonth;
Except
Result := -1;
End;
End;
Geçen ay
Function GecenAy(DateValue: TDateTime): Integer;
Var
Year, Month, Day: Word;
CurMonth : Integer;
NewMonth : Integer;
Begin
Result := -1;
Try
DecodeDate(DateValue, Year, Month, Day);
CurMonth := Integer(Month);
NewMonth := ((CurMonth + 24 - 1) mod 12);
If NewMonth = 0 Then NewMonth := 12;
Result := NewMonth;
Except
Result := -1;
End;
End;
Gün sonra
Function nGunSonra(
DateValue : TDateTime;
DateMovement : Integer): TDateTime;
Begin
Result := DateValue + DateMovement;
End;
Gelecek ay
Function GelecekAy(DateValue: TDateTime): TDateTime;
Begin
Result := nGumSonra(DateValue,1);
End;
Önceki gün
Function onceki_gun(DateValue: TDateTime): TDateTime;
Begin
Result := NGunSonra(DateValue,-1);
End;
Geçen hafta
Function GecenHaftak(DateValue: TDateTime): TDateTime;
Begin
Result := nGunSonra(DateValue,-7);
End;
Metin içerisinden bir karakter silme
Function DeleteCharacterInString(InputCharacter,InputString: String): String;
Var
CharPos : Integer;
Begin
Result := InputString;
While True Do
Begin
CharPos := Pos(InputCharacter,InputString);
If Not (CharPos = 0) Then
Begin
Delete(InputString,CharPos,1);
End
Else
Begin
Break;
End;
End;
Result := InputString;
End;
Metin içerisinden, bir karakteri değiştirme
Function ReplaceCharInString(S,OldChar,NewChar :String): String;
Var
NewString : String;
i : Integer;
L : Integer;
C : String;
Begin
Result := '';
NewString := '';
L := Length(S);
If L = 0 Then Exit;
If Pos(UpperCase(OldChar),UpperCase(S)) = 0 Then
Begin
Result := S;
Exit;
End;
For i := 1 To L Do
Begin
C := SubStr(S,i,1);
If UpperCase(C) = UpperCase(OldChar) Then
Begin
NewString := NewString + NewChar;
End
Else
Begin
NewString := NewString + C;
End;
End;
Result := NewString;
End;
Bir metni belli bir uzunluğa tamamlama
Function StringPad(
InputStr,//tamamlanacak metin
FillChar: String;//tamamlama karakteri
StrLen: Integer;//uzunluk
StrJustify: Boolean): String;//tamamlama yönü
Var
TempFill: String;
Counter : Integer;
Begin
If Not (Length(InputStr) = StrLen) Then
Begin
If Length(InputStr) > StrLen Then
Begin
InputStr := SubStr(InputStr,1,StrLen);
End
Else
Begin
TempFill := '';
For Counter := 1 To StrLen-Length(InputStr) Do
Begin
TempFill := TempFill + FillChar;
End;
If StrJustify Then
Begin
InputStr := InputStr + TempFill;
End
Else
Begin
InputStr := TempFill + InputStr ;
End;
End;
End;
Result := InputStr;
End;
Metin değiştirme
Function String_Replace(
OldSubString : String;//atılacak metin
NewSubString : String;//atılanın yerine konacak metin
SourceString : String): String;//üzerinde dğişiklik
//yapılacak metin
Var
P : Integer;
S : String;
R : String;
LOld : Integer;
LNew : Integer;
Begin
S := SourceString;
R := '';
LOld := Length(OldSubString);
LNew := Length(NewSubString);
Result := S;
If OldSubString = '' Then Exit;
If SourceString = '' Then Exit;
P := Pos(OldSubString,S);
If P = 0 Then
Begin
R := S;
End
Else
Begin
While P <> 0 Do
Begin
Delete(S,P,LOld);
R := R + Copy(S,1,P-1)+NewSubString;
S := Copy(S,P,Length(S)-(P-1));
P := Pos(OldSubString,S);
If P = 0 Then R := R + S;
End;
End;
Result := R;
End;
Program içerisinden, başka bir uygulamaya tuş gönderme
WinHand := FindWindow(nil,'Untitled - Notepad');
SetForegroundWindow(WinHand);
keybd_event(VK_MENU, 0, 0, 0);
keybd_event(VK_Menu, 0, KEYEVENTF_KEYUP, 0);
keybd_event(VK_right, 0, 0, 0);
keybd_event(VK_right, 0, KEYEVENTF_KEYUP, 0);
keybd_event(VK_right, 0, 0, 0);
keybd_event(VK_right, 0, KEYEVENTF_KEYUP, 0);
keybd_event(VK_right, 0, 0, 0);
keybd_event(VK_right, 0, KEYEVENTF_KEYUP, 0);
keybd_event(VK_down, 0, 0, 0);
keybd_event(VK_down, 0, KEYEVENTF_KEYUP, 0);
keybd_event(VK_down, 0, 0, 0);
keybd_event(VK_down, 0, KEYEVENTF_KEYUP, 0);
keybd_event(VK_return, 0, 0, 0);
keybd_event(VK_return, 0, KEYEVENTF_KEYUP, 0);
Programı Deneme sürümü haline getirme
Programcıların kabusu, ürünlerinin kolaylıkla bedavacıların eline geçmesidir. Bu durum ürünlerin tanıtım sürümlerinin dağıtılmasında bir takım tedbirleri gerektirir. Bunun çok çeşitli yolları vardır. İşte bunlardan birisi. Aşağıdaki fonksiyon, Windows'un global atom tablosuna belirli bir not yazarak, çalışma esnasında bu notu okumaktadır. Şayet not okunabilirse, programın daha önce çalıştırılmış olduğu ortaya çıkar ve uyarı mesajını takiben çalışması durdurulur. Programın yeniden çalıştırılabilmesi için, Windowsun yeniden başlatılması gerekir.
procedure TForm1.FormShow(Sender : TObject);
var atom : integer;
CRLF : string;
begin
if
GlobalFindAtom('Kontrol için kullanılacak metin') = 0 then
atom := GlobalAddAtom(' Kontrol için kullanılacak metin ')
else
begin
CRLF := #10 + #13;
ShowMessage('Bu program, her windows sezonunda 1
kez çalışır.'+crlf+'+
Windows'u yeniden başlatın.'+crlf+
'Ya da bizi arayıp satın alın');
Close;
end;
end;
ListBox bileşenine yatay kaydırma çubuğu eklenmesi
Delphi'nin TlistBox Bileşeni, satır sayısı gösterebileceğinden fazla ise, otomatik olarak dikey kaydırma çubuğunu kullanıma açar. Fakat satır uzunluğu gösterebileceği genişlikten daha fazla ise, bir kolaylık sağlamaz. Aşağıdaki kod kullanılarak, yatay kaydırma çubuğununda eklenmesi sağlanabilir.
Aşağıdaki kod, formun OnCrate olay yordamına yazılmalıdır.
procedure TForm1.FormCreate(Sender: TObject);
var
i, MaxWidth: integer;
begin
MaxWidth := 0;
for i := 0 to ListBox1.Items.Count - 1 do
if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then
MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]);
SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0);
end;
Kod öncelikle, listbox içerisindeki en uzun satırın uzunluğunun Piksel cinsinden hesaplar. Ondan sonra LB_SETHORIZONTALEXTENT mesajını kullanarak, yatay kaydırma çubuğunu ayarlar.
Kontrol panel apletlerinin Delphi içerisinden kullanılması
Bazı sistem ayarları, kontrol panelden yapılmaktadır. Program içerisinden bu ayarlara müdahele etmek gerektiğinde, en kolay yol yine kontrol panel apletlerini kullanmaktır. Aşağıdaki fonksiyon, istenen kontrol panel apletini çalıştırmaktadır.
unit open_cpl;
interface
function RunControlPanelApplet(
sAppletFileName : string) : integer;
implementation
uses Windows;
//sAppletFileName değeri aşağıdaki tablodan seçilebilir.
function RunControlPanelApplet(
sAppletFileName : string) : integer;
begin
Result :=
WinExec(
PChar('rundll32.exe shell32.dll,'+
'Control_RunDLL '+sAppletFileName),
SW_SHOWNORMAL);
end;
end.
Windows95 ve NT de ortak olan kontrol panel apletleri şunlardır.
access.cpl Erişilebilirlik
appwiz.cpl Program ekle/kaldır
desk.cpl Görüntü
intl.cpl Bölgesel ayarlar
joy.cpl Oyun çubuğu
main.cpl Fare
mmsys.cpl Çoklu ortam
modem.cpl Modem
sysdm.cpl Sistem
timedate.cpl Tarih/Saat
Sistem Tarih/Saat ayarının değiştirilmesi
Sistemin tarih ve saat ayarları programsal olarak da değiştirilebilir. Bunun için Aşağıdaki fonksiyonu kullanabilirsiniz.
function SetPCSystemTime(tDati: TDateTime): Boolean;
var
tSetDati: TDateTime;
vDatiBias: Variant;
tTZI: TTimeZoneInformation;
tST: TSystemTime;
begin
GetTimeZoneInformation(tTZI);
vDatiBias := tTZI.Bias / 1440;
tSetDati := tDati + vDatiBias;
with tST do
begin
wYear := StrToInt(FormatDateTime('yyyy', tSetDati));
wMonth := StrToInt(FormatDateTime('mm', tSetDati));
wDay := StrToInt(FormatDateTime('dd', tSetDati));
wHour := StrToInt(FormatDateTime('hh', tSetDati));
wMinute := StrToInt(FormatDateTime('nn', tSetDati));
wSecond := StrToInt(FormatDateTime('ss', tSetDati));
wMilliseconds := 0;
end;
SetPCSystemTime := SetSystemTime(tST);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
tti:tdatetime;
begin
tti:=strtodatetime('11.11.98 14:15:20');
Setpcsystemtime(tti)
· ALT+TAB ve CTRL+ALT+DEL tuş kombinasyonlarının kullanıma kapatılması
Eğer programınız çalışırken, kullanıcıların bu tuş kombinasyonlarını kullanmasını istemiyorsanız, aşağıdaki kod örneği tam size göre
uses
WinProcs;
{$R *.RES}
var
Dummy : integer;
begin
Dummy := 0;
//ALT+TAB kombinasyonu için
SystemParametersInfo( SPI_SETFASTTASKSWITCH, 1, @Dummy, 0);
//CTRL+ALT+DEL kombinasyonu için
SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @Dummy, 0);
end.
Ekran koruyucunun devreden çıkarılması
SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 0, Addr(SaverActive), 0);
if SaverActive then
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, nil, SPIF_UPDATEINIFILE);
Burada "SaverActive" global bir Boolean değişkendir. Ekran koruyucu tekrar aktif hale getirilmek istendiğinde ise
if SaverActive then
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, nil, SPIF_UPDATEINIFILE);
Diğer bir yol ise, şu şekildedir. Bir ekran koruyucu çalışmaya başlamadan önce "WM_SYSCOMMAND" mesajı gönderir. Bu mesaj yakalanarak ekran koruyucunun devreye girmesi engellenir. TApplication nesnesinin OnMessage. Olayı yerine kullanılacak yeni bir davranış yaratıp bu mesajı herkesden önce yakalayabiliriz.
Bu işlem şöyle olur.
procedure AppMessage(var Msg: TMsg; var Handled: Boolean);
Daha sonra ana formun OnCreate davranışı içerisinde,
Application.OnMessage := AppMessage;
Appmessage yordamında yakalanan mesajın WM_sysCommand ve Wparam değerinin de SC_ScreenSave olup olmadığı kontrol edilir. Eğer öyle ise, Handled parametresi True yapılarak, o mesajın işlem gördüğü imajı yaratılarak, windows'un ekran koruyucuyu başlatması engellenir.
procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
begin
if (Msg.Message = WM_SYSCOMMAND) and
((Msg.wParam) = SC_SCREENSAVE) then begin
Handled := True;
end;
end;
Programın, windowsun başlangıcında çalıştırılması
Windows Startup klasörüne konan programlar, windowsun başlaması ile birlikte çalışmaya başlarlar. Fakat bunu program içerisinden yapmak istiyorsanız, veya programınız, bir kereye mahsus başlangıçta çalışsın istiyorsanız,aşağıdaki fonksiyonu kullanarak geçici veya kalıcı olarak gerekeni yapabilirsiniz.
procedure RunOnStartup(
sProgTitle,
sCmdLine : string;
bRunOnce : boolean );
var
sKey : string;
reg : TRegIniFile;
begin
if( bRunOnce )then
sKey := 'Once'
else
sKey := '';
reg := TRegIniFile.Create( '' );
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.WriteString(
'Software\Microsoft'
+ '\Windows\CurrentVersion\Run'
+ sKey + #0,
sProgTitle,
sCmdLine );
reg.Free;
end;
Hata mesajı kontrolü
Herhangi bir iş yapılırken, örneğin, diskete erişilmek istendiğinde, eğer sürücüde disket yoksa, windows bir hata mesajı verir. Bu tür mesajlara krıtik hata mesajı denir. Eğer kendiniz bu hataları kontrol edip, gereğini yapacaksanız, windowsun mesaj vermesinin engellenmesi gerekir.Bu işlem "SetErrorMode" fonksiyonu ile yapılabilir.
var
wOldErrorMode : Word;
begin
wOldErrorMode :=
SetErrorMode(
SEM_FAILCRITICALERRORS );
try
{
hata mesajına sebep olabilecek kod buraya yazılır.
}
finally
{
bir önceki hata moduna dön.
}
SetErrorMode( wOldErrorMode );
end;
end;
Ekran koruyucu kurulması
Sistemde tanımlı olan ekran koruyucunun değiştirilmesi veya en baştan tanımlanması için gereken kod aşağıdadır. Uses listesine eklenmesi gereken fmxutil.pas demos\doc dizini altında bulunmaktadır.
//uses ..\demos\doc\fmxutil.pas
procedure TForm1.Button1Click(Sender: TObject);
begin
ExecuteFile('rundll32.exe',
'desk.cpl,InstallScreenSaver C:\Windows\gpf.scr',
'',
SW_SHOW);
end;
ListBox yazı tipinin değiştirilmesi
Tek bir satır kod yazarak wm_SetFont mesajına duyarlı bileşenlerin, yazı tipleri değiştirilebilir.
SendMessage( Listbox1.handle, wm_SetFont, GetStockObject(System_Fixed_Font), 1);
Taşınabilir Panel
Programın çalışması esnasında, form üzerindeki bileşenlerin yerleri ancak, program içerisinden verilecek komutlarla değiştirilebilir. Aşağıdaki kod örneği ile çalışan bir programda, normal bir panel, fare yardımı ile taşınabilir hale gelmektedir. Bu kod panelin OnMouseDown olay yordamı içerisine yazılmalıdır.
procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
SC_DragMove = $F012;
begin
ReleaseCapture;
panel1.perform(WM_SysCommand, SC_DragMove, 0);
end;
CD-ROM kapağının kapatılması
TmediaPlayer, bir CD-ROM'a komuta ediyorsa, Eject tuşuna basıldığında,, CD-ROM kapağını açabilir. Fakat tekrar Eject tuşuna basıldığında açık durumdaki kapağı kapatamaz. Bu nedenle bir adet kapat butonu kullanılmalıdır. Aşağıdaki kod örneğinde, başka bir buton kullanılarak kapağın kapatılması gösterilmektedrir.
procedure TForm1.Button1Click(Sender: TObject);
begin
if MediaPlayer1.Mode = mpOpen then
begin
mciSendCommand(MediaPlayer1.DeviceID,
MCI_SET,MCI_SET_DOOR_CLOSED,0);
Button1.Caption := '&Open'
end
else
begin
mciSendCommand(MediaPlayer1.DeviceID
,MCI_SET,MCI_SET_DOOR_OPEN,0);
Button1.Caption := '&Close';
end;
end;
Genel olarak bu işlemin yapılması için ise Mmsystem uniti kullanılarak, aşağıdaki fonksiyonlar kullanılabilir.
CD-ROM Kapağını açmak için;
mciSendString('Set cdaudio door open wait', nil, 0, handle);
CD-ROM Kapağını kapatmak için;
mciSendString('Set cdaudio door closed wait', nil, 0, handle);
Çalışma esnasında, bileşen sayısının kontrolü
Uygulama tarafından kullanılmakta olan bileşen sayısının bulunması mümkündür. Henüz yaratılmamış olanlar, bu sayıya dahil edilmeyecektir. Uygulamalar tarafından kullanılmakta olan formların tümü Screen nesnesi ne bağlıdırlar. Her formun üzerindeki bileşenlerin sayısı ise ComponentCount özelliğinde saklanmaktadır. Aşağıdaki kod örneğinde bu özelliklerden yararlanılarak, uygulama üzerindeki toplam bileşen sayısı bulunmaktadır.
function BilesenSayisi : Integer;
var
TopBilesen,
F_Form : Integer;
begin
TopBilesen := 0;
for F_Form := 0 to (Screen.FormCount - 1) do begin
TopBilesen := TopBilesen + Screen.Forms[F_Form].ComponentCount;
end;
Result := TopBilesen;
end;
Fare imlecinin, istenen kontrol üzerine getirilmesi
Fare imlecinin form üzerindeki kontrollerden birisi, örneğin bir buton üzerine getirilmesi için;
Butonun orta noktası hesaplanmalıdır. Örneğin butonun eni 24 ve boyu da 24 ise
xC := Buton.Left + ( buton.width div 2 );
yC := buton.Top + ( buton.height div 2 );
Bulunan değerler Tpoint kayıt tipi içerisine yerleştirilir.
ptBtn : TPoint;
Btn := Point( xC, yC );
Butonun orta noktasına karşılık gelen ekran koordinatları bulunmalıdır.
ptBtn:=buton.Parent.ScreenToClient( buton.ClientToScreen (ptBtn ));
Fere imlecinin pozisyonunu, bulunan ekran koordinatı değeri kullanılarak değiştirilir.
SetCursorPos( ptBtn.X, ptBtn.Y );
Alt-? Tuş kombinasyonu
Bir çok uygulamaya, programcılar tarafından çeşitli maksatlarla, genellikle de geliştirme ekibi hakkında bilgi vermek için, gizli, sürpriz pencereler yerleştirilmektedir. Zaman zaman dergilerde bu tür uygulamalarla ilgili bilgiler yayınlanmaktadır. Bu tekniği kendi programlarınız içerisinde de kullanabilirsiniz.. Aşağıdaki kod örneğinde, form üzerinde tuşa basıldığında, karakterler bir dizi haline getirilip, listedekilerle karşılaştırılmaktadır. listedekilerden bir tanesi ile çakıştığında ise bir mesaj gösterilmektedir.
unit surpriz;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
Tst=array[1..4] of string;
const
strings:Tst= ('merhaba','güle güle','sürüm','sürpriz');
type
TForm1 = class(TForm)
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
s:string;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
var
i:integer;
tamam:integer;
begin
if (shift=[ssalt]) and (key>=$41) and (key<=$5A) then begin
s:=s+chr(key);
tamam:=0;
for i:=1 to 4 do
begin
if (s=copy(strings[i],1,length(s))) then Tamam:=-i;
if (s=strings[i]) then Tamam:=i;
end;
if Tamam=0 then s:='';
if Tamam>0 then showmessage(strings[Tamam]);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
S:='';
end;
end.
Programın duraklatılması
Uses
....
Winprocs
....;
Procedure delay(millisecs : longint);
{ Milisaniyelik duraklatma }
var
Bitir : longint;
begin
bitir := gettickcount + millisecs;
while bitir - gettickcount < 0 do
Application.ProcessMessages;
end; { delay }
Delay(5000), 5 saniyelik bir duraklamaya sebep olur.
Yazı karakteri stilinin değiştirilmesi
with edit1 do
begin
Font.Style := Font.Style + [fsStrikeOut];
Font.Style := Font.Style + [fsUnderline];
Font.Style := Font.Style - [fsBold];
end;
Mevcut bir davranışın değiştirilmesi
Bir sınıf elemanı olan davranışın, alt sınıflarda değiştirilerek kullanılması şu şekilde olur.
Sınıf tanımının Protected bölümündeki tanımlama;
…
procedure Click ; override ;
…
Implementation bölümündeki tanımlama
procedure TYeniButton.Click ;
begin
inherited Click ;
(Owner as TForm).Close ;
end ;
Kes, Kopyala, Yapştır
Kesme, Kopyalama ve Yapıştırma işlemlerini, Klavye kullanılarak yapmak oldukça kolaydır. Bu işlemler menü elemanları vasıtasıyla da yapılabilir. Şayet bileşen, bu komutları aldığında ne yapacağını biliyorsa, Windows mesajlarını kullanmak en uygun hareket tarzıdır.
Kesme;
if GetFocus <> 0 then { Seçili bir pencere varmı? }
SendMessage( GetFocus, WM_CUT, 0, 0
Kopyalama;
if GetFocus <> 0 then { Seçili bir pencere varmı? }
SendMessage( GetFocus, WM_COPY, 0, 0
Yapıştırma;
if GetFocus <> 0 then { Seçili bir pencere varmı? }
SendMessage( GetFocus, WM_PASTE, 0, 0);
Fare imlecinin, pencere üzerinde olup olmadığının kontrolü
Form'un OnMouseMove olayında;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
P : TPoint;
begin
P.X := X;
P.Y := Y;
if PtInRect (ClientRect,P) then {bütün pencere için sadece "rect"}
MouseCapture := True
else
begin
MouseCapture := False;
ShowMessage ('Benim üzerimde değil');
end;
end;
GetKeyBoardState
Sistem tuşlarının durumunu öğrenmenin en kolay yolu, klavye üzerindeki LED'lere bakmaktır. Kod içerisinden bunu anlamanın yolu ise aşağıdadır.
Tuş durumları, paneller üzerindeki yazının sönük veya koyu olması ile gösterilmektedir. Bu nedenle form üzerine 4 adet panel yerleştirip isimlerini Captio özelliklerini ayarlayın. Ttimer bileşeninin OnTimer olayına da aşağıdaki kodu yazın.
procedure TForm1.Timer1Timer(Sender: TObject);
const
vkconsts: array[0..3] of Word=(vk_Scroll, vk_Insert, vk_Capital, vk_NumLock);
PanelColor: array[Boolean] of TColor=(clGray, clBlack);
var
Toggles: array[0..3] of Bool;
Panels: array[0..3] of TPanel ;
I: Integer;
begin
for I := Low(vkconsts) to High(vkconsts) do
begin
Toggles[I] := Bool(GetKeyState(vkconsts[I]) and 1);
if stToggles[I]<>Toggles[I] then
begin
stToggles[I] := Toggles[I];
case i of
0:PanelScrollLock.Font.Color:=PanelColor[Toggles[I]];
1:PanelINS.Font.Color:=PanelColor[Toggles[I]];
2: PanelCAPS.Font.Color:=PanelColor[Toggles[I]];
3:PanelNUM.Font.Color:=PanelColor[Toggles[I]];
end;
end;
end;
end;
Olay yakalama yordamlarının dinamik olarak atanması
Dinamik olarak bir PopUp menü yaratıldığında, menü elemanlarının altına, seçildiklerinde yapacakları işlerle ilgili olarak doğrudan kod yazmak mümkün değildir. Bunun yerine, hangi menü elemanının ne yapacağını bilen tek bir yordam yazıp, gerektiğinde çağırabilirsiniz. Sender özelliğine göre, seçilen menü elemanı da tespit edilip, gereken kod çalıştırılabilir.
procedure MyPopUpClick(Sender : TObject);
begin
end;
Yukarıdaki yordam PopUp menünün OnClick olayına şu şekilde eşitlenir.
procedure TForm1.TestButtonClick(Sender: TObject);
begin
:
MyPopUp.OnClick = MyPopUpClick;
:
end;
Sender parametresinin kullanılması
with Sender as TEdit do
begin
case Tag of
1: birşeyler yap
2: Başka birşeyler yap
end; {case}
end;
Büyük metinlerin panodan alınması
var
Buffer: PChar;
MyHandle : THandle;
TextLength : Integer;
begin
MyHandle := Clipboard.GetAsHandle(CF_TEXT);
Buffer := GlobalLock(MyHandle);
If Buffer = Nil then
begin
GlobalUnlock(MyHandle);
exit;
end;
TextLength := StrLen(buffer);
Windows sürüm numarasının okunması
GetVersion api fonksiyonu kullanılarak, çalışmakta olan Windows'un sürüm numarası nasıl alınabilir. Bu fonksiyonun dödürdüğü sonuç içerisinde sürüm numarası nasıl ayıklanır?
program Winvrsn;
uses
WinTypes,
WinProcs,
SysUtils;
procedure TForm1.Button2Click(Sender: TObject);
var
WinVersion : Word;
DosVersion : Word;
VersionString : String;
begin
WinVersion := GetVersion and $0000FFFF;
DosVersion := (GetVersion and $FFFF0000) shr 16;
VersionString := 'DOS : ' + IntToStr(Hi(DOSVersion)) + '.' + IntToStr(Lo(DOSVersion)) + #13 +
'Windows : '+ IntToStr(Lo(WinVersion)) + '.' + IntToStr(Hi(WinVersion)) + #0;
MessageBox(0, @VersionString[1],'Version Information', MB_ICONINFORMATION or MB_OK)
end;
Program guruplarının listbox bileşenine doldurulması
Sistemde tanımlı olan program guruplarının elde edilip, bir listbox içerisine doldurulması için neler yapılmalıdır?
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, DdeMan;
type
TForm1 = class(TForm)
Button1: TButton;
FGroupsList: TListBox;
FDDEClient: TDdeClientConv;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
Procedure ReadGroups;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
Procedure TForm1.ReadGroups;
Var
GroupData : PChar;
TmpStr : String;
FNumGroups, i : integer;
begin
GroupData := FDDEClient.RequestData('Groups');
FGroupsList.Clear;
FNumGroups := 0;
if GroupData = nil then
exit
else
begin
i := 0;
TmpStr := '';
While GroupData[i] <> #0 do
begin
if GroupData[i] = #13 then
begin
FGroupsList.items.Add(TmpStr);
TmpStr := '';
i := i + 1;
end
else
TmpStr := TmpStr + GroupData[i];
i := i + 1;
end;
end;
StrDispose(GroupData);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ReadGroups
end;
end.
Yukarıdaki kod için kullanılan form ise şu şekildedir.
object Form1: TForm1
Left = 200
Top = 111
Width = 374
Height = 486
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 120
TextHeight = 16
object Button1: TButton
Left = 280
Top = 408
Width = 75
Height = 41
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
object FGroupsList: TListBox
Left = 8
Top = 0
Width = 265
Height = 449
ItemHeight = 16
TabOrder = 1
end
object FDDEClient: TDdeClientConv
DdeService = 'progman'
Left = 48
Top = 88
LinkInfo = (
'Service progman'
'Topic ')
end
end
TListBox ve TComboBox bileşenleri içerisine resim yerleştirilmesi
ListBox ve ComboBox bileşenleri içerisine yerleştirilen seçimlik elemanların, sadece metin değil, aynı zamanda BMP formatındaki resimleri de içermesi, tasarladığınız kullanıcı arayüzlerinin, diğerlerinden farklı olmasını sağlar. Bunun için hazırlanmış olan örnek kod aşağıdadır.
Unit1.pas;
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
ComboBox1: TComboBox;
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure ListBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
TheBitmap1, TheBitmap2, TheBitmap3, TheBitmap4,
TheBitmap5 : TBitmap;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
TheBitmap1 := TBitmap.Create;
TheBitmap1.LoadFromFile('C:\Program Files\Borland\Delphi 3\images\buttons\globe.bmp');
TheBitmap2 := TBitmap.Create;
TheBitmap2.LoadFromFile('C:\Program Files\Borland\Delphi 3\images\buttons\video.bmp');
TheBitmap3 := TBitmap.Create;
TheBitmap3.LoadFromFile('C:\Program Files\Borland\Delphi 3\images\buttons\gears.bmp');
TheBitmap4 := TBitmap.Create;
TheBitmap4.LoadFromFile('C:\Program Files\Borland\Delphi 3\images\buttons\key.bmp');
TheBitmap5 := TBitmap.Create;
TheBitmap5.LoadFromFile('C:\Program Files\Borland\Delphi 3\images\buttons\tools.bmp');
ComboBox1.Items.AddObject('Bitmap1: Globe', TheBitmap1);
ComboBox1.Items.AddObject('Bitmap2: Video', TheBitmap2);
ComboBox1.Items.AddObject('Bitmap3: Gears', TheBitmap3);
ComboBox1.Items.AddObject('Bitmap4: Key', TheBitmap4);
ComboBox1.Items.AddObject('Bitmap5: Tools', TheBitmap5);
ListBox1.Items.AddObject('Bitmap1: Globe', TheBitmap1);
ListBox1.Items.AddObject('Bitmap2: Video', TheBitmap2);
ListBox1.Items.AddObject('Bitmap3: Gears', TheBitmap3);
ListBox1.Items.AddObject('Bitmap4: Key', TheBitmap4);
ListBox1.Items.AddObject('Bitmap5: Tools', TheBitmap5);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
TheBitmap1.Free;
TheBitmap2.Free;
TheBitmap3.Free;
TheBitmap4.Free;
TheBitmap5.Free;
end;
procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
Bitmap: TBitmap;
Offset: Integer;
begin
with (Control as TComboBox).Canvas do
begin
FillRect(Rect);
Bitmap := TBitmap(ComboBox1.Items.Objects[Index]);
if Bitmap <> nil then
begin
BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
Bitmap.Height), clRed);
Offset := Bitmap.width + 8;
end;
{ display the text }
TextOut(Rect.Left + Offset, Rect.Top, Combobox1.Items[Index])
end;
end;
procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index:Integer; var Height: Integer);
begin
height:= 20;
end;
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
Bitmap: TBitmap;
Offset: Integer;
begin
with (Control as TListBox).Canvas do
begin
FillRect(Rect);
Bitmap := TBitmap(ListBox1.Items.Objects[Index]);
if Bitmap <> nil then
begin
BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
Bitmap.Height), clRed);
Offset := Bitmap.width + 8;
end;
{ display the text }
TextOut(Rect.Left + Offset, Rect.Top, Listbox1.Items[Index])
end;
end;
procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
begin
height:= 20;
end;
end.
Unit1.dfm
object Form1: TForm1
Left = 211
Top = 155
Width = 526
Height = 320
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -16
Font.Name = 'System'
Font.Style = []
OnClose = FormClose
OnCreate = FormCreate
PixelsPerInch = 120
TextHeight = 20
object ComboBox1: TComboBox
Left = 33
Top = 38
Width = 206
Height = 22
Style = csOwnerDrawVariable
ItemHeight = 16
TabOrder = 0
OnDrawItem = ComboBox1DrawItem
OnMeasureItem = ComboBox1MeasureItem
end
object ListBox1: TListBox
Left = 270
Top = 35
Width = 189
Height = 209
ItemHeight = 16
Style = lbOwnerDrawVariable
TabOrder = 1
OnDrawItem = ListBox1DrawItem
OnMeasureItem = ListBox1MeasureItem
end
end
Basit bir DLL şablonu
Delphi'de DLL hazırlamak hiç te zor değil. Aşağıdaki kod örneği derlendiğinde, uzantısı otomatik olarak,DLL olarak verilecektir.. Bu DLL "Fonksiyon" isimli tek bir fonksiyon ihraç etmektedir.
library Dllframe;
uses WinTypes;
function Fonksiyon : string ; export ;
begin
Result := 'DLL' den merhaba!' ;
end;
exports
Fonksiyon;
begin
end.
İpucu penceresinin özelleştirilmesi
Standart ipucu penceresi, kısmen de olsa özelleştirilebilir. İşte örneği.
Type
TMyHintWindow = Class (THintWindow)
Constructor Create (AOwner: TComponent); override;
end;
var
Form1: TForm1;
implementation
Constructor TMyHintWindow.Create (AOwner: TComponent);
begin
Inherited Create (AOwner);
canvas.brush.color:=clwhite;
Canvas.Font.Name := 'Courier New';
Canvas.Font.Size := 72;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.ShowHint := false;
HintWindowClass := TMyHintWindow;
Application.ShowHint := True;
end;
Dizi sabiti tanımı
TYPE
NAME1 = Array[1..4,1..10] of Integer;
Const
NAME2 : NAME1 = ((1,2,3,4,5,6,7,8,9,10),
(1,2,3,4,5,6,7,8,9,10),
(1,2,3,4,5,6,7,8,9,10),
(1,2,3,4,5,6,7,8,9,10));
StrinGrid bileşeni içerisindeki metnin hizalaması
StringGrid bileşeni hücrelerindeki metin, Grid1DrawCell olay yordamına eklenecek birkaç satır kodla hizalanabilir.
procedure Tform1.Grid1DrawCell(Sender: TObject; Col, Row: Longint;
Rect: TRect; State: TGridDrawState);
var l_oldalign : word;
begin
if (row=0) or (col<2) then
grid1.canvas.font.style:=grid1.canvas.font.style+[fsbold];
if col<>1 then
begin
l_oldalign:=settextalign(grid1.canvas.handle,ta_right);
grid1.canvas.textrect(rect,rect.right-2, Rect.top+2,grid1.cells[col,row]);
settextalign(grid1.canvas.handle,l_oldalign);
end
else
begin
grid1.canvas.textrect(rect,rect.left+2,rect.top+2,grid1.cells[col,row]);
end;
grid1.canvas.font.style:=grid1.canvas.font.style-[fsbold];
end;
end.
TstringGrid bileşeninden bir satırın silinmesi
Bu fonksiyonu "RowNumber" parametresi ile belirtilen satırı StringGrid bileşeninden siler.
procedure GridDeleteRow(RowNumber : Integer; Grid : TStringGrid);
Var
i : Integer;
Begin
Grid.Row := RowNumber;
If (Grid.Row = Grid.RowCount -1) Then
Begin
{On the last row}
Grid.RowCount := Grid.RowCount - 1;
End
Else
Begin
{Not the last row}
For i := RowNumber To Grid.RowCount - 1 Do
Begin
Grid.Rows[i] := Grid.Rows[i+ 1];
End;
Grid.RowCount := Grid.RowCount - 1;
End;
End;
TstringGrid satırının en alta gönderilmesi
Bu fonksiyon, "RowNumber" parametresi ile belirtilen satırı, StringGrid bileşeninin en son satırına gönderir.
procedure GridMoveRowToBottom(RowNumber : Integer; Grid : TStringGrid);
Var
i : Integer;
Begin
Grid.Row := RowNumber;
Grid.RowCount := Grid.RowCount + 1;
Grid.Rows[Grid.RowCount-1] := Grid.Rows[Grid.Row];
For i := RowNumber+1 To Grid.RowCount -1 Do
Begin
Grid.Rows[i-1] := Grid.Rows[i];
End;
Grid.RowCount := Grid.RowCount - 1;
End;
Sistemde tanımlı yazıcıların listelenmesi
//uses printers
var
printer:tprinter;
begin
printer:=tprinter.create;
listbox1.items.assign(printer.printers)
end;
Yazdırma
Kullanıcı butona bastığında, bir adet Bitmap nesnesi yaratılıp, içeriği dosyadan alınmakta ve kağıdı ortalayacak şekilde resim basılmaktadır.
//uses printers
procedure TForm1.Button1Click(Sender: TObject);
var
TBitmap bmp;
begin
bmp = TBitmap.Create;
bmp.LoadFromFile('MyBitmap.bmp');
with Printer do
begin
BeginDoc;
Canvas.Draw((PageWidth - bmp.Width) div 2,
(PageHeight - bmp.Height) div 2,bmp);
EndDoc;
end;
bmp.Free;
end;
istenen yazıcının seçimi
Sistemde tanımlı birden fazla yazıcı varsa, yazıcılar 0'dan başlayacak şekilde numaralanır. İstenen yazıcının kullanılabilmesi veya hangi yazıcının seçili olduğunun öğrenilmesi için, Tprinter nesnesininin Printerindex özelliği kullanılır. Kullanılmakta olan yazıcının numarası bu özellikte saklanır. Değiştirilecek ise, kullanılacak yazıcının numarası, yine bu özelliğe atanır. Bu özellikte "-1" değeri varsa, varsayılan yazıcı seçili muamelesi görür.
//uses printers
var
printer:tprinter;
begin
printer:=tprinter.create;
printer.printerindex:=0;
end;
Yazıcı yazı tipleri
Seçili durumaki yazıcı tarafından desteklenmekte olan yazı tipleri aşağıdaki yöntemle listelenir.
//uses printers
var
printer:tprinter;
begin
printer:=tprinter.create;
listbox1.items.assign(printer.fonts)
end;
HEX->Dec
Aşağıdaki fonksiyon, 16 tabanındaki bir sayının ondalık sayıya çevirilmesi için kullanılabilecek bir fonksiyondur.
procedure TForm1.Button1Click(Sender: TObject);
CONST HEX : ARRAY['A'..'F'] OF INTEGER = (10,11,12,13,14,15);
VAR str : String;
Int,
i : integer;
BEGIN
STR:=EDIT1.TEXT;
Int := 0;
FOR i := 1 TO Length(str) DO
IF str[i] < 'A' THEN Int := Int * 16 + ORD(str[i]) - 48
ELSE Int := Int * 16 + HEX[str[i]];
edit1.text:=inttostr(int);
end;
Hafıza miktarı
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
Function MyGetExt: Integer; Assembler;
asm
Mov AX,$3031;
Out $70,AL;
NOP;
IN AL,$71;
XCHG AH,AL;
Out $70,AL;
NOP;
IN AL,$71;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
showmessage(inttostr(MyGetExt))
end;
end.
Fare hareket alanının kısıtlanması
Aşağıdaki kod örneğinde, farenin sol tuşuna basılıyken, imleç form üzerinden başka bir yere taşınamamaktadır.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
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);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
r:trect;
begin
canvas.pen.mode:=pmxor;
canvas.Pen.style:=psdot;
r:=boundsrect;
inflaterect(r,-30,-30);
clipcursor(@r);
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
clipcursor(nil);
end;
end.
PgUp ve PgDown tuşları ile formu aşağı yukarı kaydırma
Kalabalık veya küçültülmüş formlarda, bazı kontroller, görünmeyen bölgede kalırlar. Gerektiğinde Kaydırma çubukları ile formun görünmeyen bölgelerine ulaşmak elbetteki mümkündür. Bu işlem, klavye kullanılarak da şu şekilde yapılabilir.
Form.Keypreview özelliği TRUE olmalıdır.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Edit1: TEdit;
Memo1: TMemo;
ListBox1: TListBox;
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
const
delta=10;
begin
with vertscrollbar do
if key=vk_next then position:=position+delta
else if key=vk_prior then position:=position-delta;
end;
end.
Özel yazı karakteri
Kendi yazı karakterinizi kullanın.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
dc:hdc;
thefont:hfont;
begin
dc:=getdc(handle);
thefont:=createfont( 24, //yükseklik
16, //ortalama karakter genişliği
0, //yatış açısı
0, //yönlendiröe açısı
400,//yazı karakteri ağırlığı
0, //italiklik bayrağı
0, //alt çizgi bayrağı
0, //vurgu bayrağı
oem_charset,// karakter seti
out_default_precis,//çıkış vurgusu
clip_default_precis,//kesme vurgusu
default_quality,//çıktı kalitesi
default_pitch or ff_script,//vurgu ve aile
'script'//ad
);
selectobject(dc,thefont);
textout(dc,10,10,'Merhaba Dünya',24);
releasedc(handle,dc);
deleteobject(thefont);
end;
end.
Ekran koruyucu
Bir ekran koruyucusu nasıl olur. İşte örneği:
· Proje dosyasına, projenin ekran koruyucu olacağına dair bir bilgi satırı eklenmelidir.
{$D SCRSAVE <Ekran koruyucu adı}>
· Ana formdaki kenarlıklar, ve ikonlar tamamen kaldırılmalıdır.
· Form aktif hale gelirken, Left ve Top değerleri "0" a eşitlenmelidir.
· Form.Windowstate=WsMaximized olmalıdır.
· Formun yaratılması esnasında, Application.Onmessage olay yordamına, Ekran koruyucunun devreden çıkmasını sağlayacak yordam atanmalıdır.
· Program parametrelerine "/c" eklenmelidir. (Run | Parameters menüsünden)
· Program derlendikten sonra uzantısı "SCR" olarak değiştirilmeli ve Windows dizinine kopyalanmalıdır.
Scrn.PAS
unit Scrn;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls;
type
TScrnFrm = class(TForm)
tmrTick: TTimer;
procedure tmrTickTimer(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormHide(Sender: TObject);
procedure FormActivate(Sender: TObject);
private
{ Private declarations }
procedure DrawSphere(x, y, size : integer; color : TColor);
procedure DeactivateScrnSaver(var Msg : TMsg; var Handled : boolean);
public
{ Public declarations }
end;
var
ScrnFrm: TScrnFrm;
implementation
{$R *.DFM}
var
crs : TPoint; {Fare imlecinin orjinal yeri.}
function Min(a, b : integer) : integer;
begin
if b < a then
Result := b
else
Result := a;
end; {Min}
procedure TScrnFrm.DrawSphere(x, y, size : integer; color : TColor);
var
i, dw : integer;
cx, cy : integer;
xy1, xy2 : integer;
r, g, b : byte;
begin
with Canvas do begin
{Fırça ve kalem şekilleri.}
Pen.Style := psClear;
Brush.Style := bsSolid;
Brush.Color := color;
{Renk karışımları.}
r := GetRValue(color);
g := GetGValue(color);
b := GetBValue(color);
{Topların çizimi.}
dw := size div 16;
for i := 0 to 15 do begin
xy1 := (i * dw) div 2;
xy2 := size - xy1;
Brush.Color := RGB(Min(r + (i * 8), 255), Min(g + (i * 8), 255),
Min(b + (i * 8), 255));
Ellipse(x + xy1, y + xy1, x + xy2, y + xy2);
end;
end;
end; {TScrnFrm.DrawSphere}
procedure TScrnFrm.DeactivateScrnSaver(var Msg : TMsg; var Handled : boolean);
var
done : boolean;
begin
if Msg.message = WM_MOUSEMOVE then
done := (Abs(LOWORD(Msg.lParam) - crs.x) > 5) or
(Abs(HIWORD(Msg.lParam) - crs.y) > 5)
else
done := (Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP) or
(Msg.message = WM_SYSKEYDOWN) or (Msg.message = WM_SYSKEYUP) or
(Msg.message = WM_ACTIVATE) or (Msg.message = WM_NCACTIVATE) or
(Msg.message = WM_ACTIVATEAPP) or (Msg.message = WM_LBUTTONDOWN) or
(Msg.message = WM_RBUTTONDOWN) or (Msg.message = WM_MBUTTONDOWN);
if done then
Close;
end; {TScrnFrm.DeactivateScrnSaver}
procedure TScrnFrm.tmrTickTimer(Sender: TObject);
const
sphcount : integer = 0;
var
x, y : integer;
size : integer;
r, g, b : byte;
color : TColor;
begin
Inc(sphcount);
x := Random(ClientWidth);
y := Random(ClientHeight);
size := 25;
x := x - size div 2;
y := y - size div 2;
r := Random($80);
g := Random($80);
b := Random($80);
DrawSphere(x, y, size, RGB(r, g, b));
end; {TScrnFrm.tmrTickTimer}
procedure TScrnFrm.FormShow(Sender: TObject);
begin
GetCursorPos(crs);
tmrTick.Interval := 100;
tmrTick.Enabled := true;
Application.OnMessage := DeactivateScrnSaver;
ShowCursor(false);
end; {TScrnFrm.FormShow}
procedure TScrnFrm.FormHide(Sender: TObject);
begin
Application.OnMessage := nil;
tmrTick.Enabled := false;
ShowCursor(true);
end; {TScrnFrm.FormHide}
procedure TScrnFrm.FormActivate(Sender: TObject);
begin
WindowState := wsMaximized;
end; {TScrnFrm.FormActivate}
end.
Spheres.DPR
program Spheres;
uses
Forms,
SysUtils,
Scrn in 'SCRN.PAS' {ScrnFrm};
{$R *.RES}
{$D SCRNSAVE Spheres Ekran koruyucu}
begin
{Sadece birkez çalışmalı.}
if hPrevInst = 0 then
begin
if (ParamCount > 0) and (UpperCase(ParamStr(1)) = '/S') then
begin
Application.CreateForm(TScrnFrm, ScrnFrm);
application.initialize;
Application.Run;
end else application.Terminate;
end;
end.
Bir nesnedeki özelliklerin listesi
procedure ObjectInspector(
Obj : TObject;
Items : TStrings );
var
n : integer;
PropList : TPropList;
begin
n := 0;
GetPropList(
Obj.ClassInfo,
tkProperties + [ tkMethod ],
@PropList );
while( (Nil <> PropList[ n ]) and
(n < High(PropList)) ) do
begin
Items.Add(
PropList[ n ].Name + ': ' +
PropList[ n ].PropType^.Name );
Inc( n );
end;
end;
Haberleşme portlarına erişim
Haberleşme kanallarından bilgi almak veya kanallara bilgi yazmak için aşağıdaki fonksiyonlar kullanılabilir. Belirtilen numaradaki kanala her seferinde bir Byte bilgi yazılabilir veya kanaldan 1 Byte''ık bilgi okunabilir.
function ReadPortB
( wPort : Word ) : Byte;
begin
asm
mov dx, wPort
in al, dx
mov result, al
end;
end;
procedure WritePortB
( wPort : Word; bValue : Byte );
begin
asm
mov dx, wPort
mov al, bValue
out dx, al
end;
end;
Bileşen özelliklerinin Kayıt defterinde saklanması
Bileşenlerin, Published tipindeki özellikleri, kayıt defterine yazılarak, gelecekte tekrar kullanılmak üzere saklanabilir. Örnek kod aşağıdadır.
unit unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,registry,TypInfo,
StdCtrls;
type
TForm1 = class(TForm)
xxzzbtn1: TButton;
procedure xxzzbtn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
procedure SaveToRegistry(Obj: TPersistent; Reg: TRegistry);
procedure SaveToKey(Obj: TPersistent; const KeyPath: string);
procedure SaveSetToRegistry(const Name: string; Value: Integer; gTypeInfo: PTypeInfo; Reg: TRegistry);
procedure SaveObjToRegistry(const Name: string; Obj: TPersistent; Reg: TRegistry);
procedure SavePropToRegistry(Obj: TPersistent; PropInfo: PPropInfo;Reg: TRegistry);
var
Form1: TForm1;
implementation
{$R *.DFM}
{integer sayıların, bitlerine ulaşabilmek için, bir tip kümesi oluşturulmalıdır. }
const
BitsPerByte = 8;
type
TIntegerSet = set of 0..SizeOf(Integer)*BitsPerByte - 1;
{ Özellik kümesini, ayrı bir alt anahtar altına BOLLEAN olarak kaydederek, sonradan REGEDIT vasıtasıyla düzeltme imkanı elde edilir. }
procedure SaveToRegistry(Obj: TPersistent; Reg: TRegistry);
var
PropList: PPropList;
PropCount: Integer;
I: Integer;
begin
{ Published özelliklerin listesini oluştur. }
PropCount := GetTypeData(Obj.ClassInfo)^.PropCount;
GetMem(PropList, PropCount*SizeOf(PPropInfo));
try
GetPropInfos(Obj.ClassInfo, PropList);
{ Her özelliği, mevcut anahtara ait bir değer olarak sakla }
for I := 0 to PropCount-1 do
SavePropToRegistry(Obj, PropList^[I], Reg);
finally
FreeMem(PropList, PropCount*SizeOf(PPropInfo));
end;
end;
{ Published özellikleri, verilen anahtarın altına değer olarak yaz. Bu anahtar, HKEY_CURRENT_USER.anahtarının altında yer alacaktır. }
procedure SaveToKey(Obj: TPersistent; const KeyPath: string);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
if not Reg.OpenKey(KeyPath, True) then
raise ERegistryException.CreateFmt('Anahtar yaratılamadı: %s',[KeyPath]);
SaveToRegistry(Obj, Reg);
finally
Reg.Free;
end;
end;
procedure SaveSetToRegistry(const Name: string; Value: Integer;
gTypeInfo: PTypeInfo; Reg: TRegistry);
var
OldKey: string;
I: Integer;
pppTypeInfo:PPTypeInfo;
begin
pppTypeInfo := GetTypeData(gTypeInfo)^.CompType;
OldKey := '\' + Reg.CurrentPath;
if not Reg.OpenKey(Name, True) then
raise ERegistryException.CreateFmt('Anahtar yaratılamadı: %s',[Name]);
{ Enumarated tipli değişken değerlerini teker teker dolaş }
with GetTypeData(gTypeInfo)^ do
for I := MinValue to MaxValue do
{ her küme elemanı için, bir BOOLEAN değer yaz. }
Reg.WriteBool(GetEnumName(gTypeInfo, I), I in TIntegerSet(Value));
{ Üst anahtara dön. }
Reg.OpenKey(OldKey, False);
end;
{Bütün alt nesnelerin özelliklerini, alt anahtar altına yaz}
procedure SaveObjToRegistry(const Name: string; Obj: TPersistent;Reg: TRegistry);
var
OldKey: string;
begin
OldKey := '\' + Reg.CurrentPath;
{ Nesne için bir alt anahtar aç. }
if not Reg.OpenKey(Name, True) then
raise ERegistryException.CreateFmt('Anahtar yaratılamadı: %s',[Name]);
{ Nesne özelliklerini sakla }
SaveToRegistry(Obj, Reg);
{Üst anahtara dön }
Reg.OpenKey(OldKey, False);
end;
{ Bir davranışın kayıt defterine saklanması. }
procedure SaveMethodToRegistry(const Name: string; const Method:TMethod;Reg: TRegistry);
var
MethodName: string;
begin
{ Method işaretçisi nil ise sadece boş bir karakter dizisi yaz. }
if Method.Code = nil then
MethodName := ''
else
{ davranışın adını bul. }
MethodName := TObject(Method.Data).MethodName(Method.Code);
Reg.WriteString(Name, MethodName);
end;
{ Tek bir özelliği kayıt defterine mevcut anahtarın altına kaydetmek için }
procedure SavePropToRegistry(Obj: TPersistent; PropInfo: PPropInfo;Reg: TRegistry);
begin
with PropInfo^ do
case PropType^.Kind of
tkInteger,
tkChar,
tkWChar:
begin
{ ordinal özellikleri integer olarak sakla. }
Reg.WriteInteger(Name, GetOrdProp(Obj, PropInfo));
end;
tkEnumeration:
{ enumerated değerleri kendi isimleriyle sakla. }
Reg.WriteString(Name, GetEnumName(PropType^, GetOrdProp(Obj,PropInfo)));
tkFloat:
{ floating point değerleri Double olarak sakla. }
Reg.WriteFloat(Name, GetFloatProp(Obj, PropInfo));
tkString,
tkLString:
{ Store değerler strin olarak kalsın. }
Reg.WriteString(Name, GetStrProp(Obj, PropInfo));
tkVariant:
{ variant değerler string olarak saklansın. }
Reg.WriteString(Name, GetVariantProp(Obj, PropInfo));
tkSet:
{ kümeler alt anahtara saklansın. }
SaveSetToRegistry(Name, GetOrdProp(Obj, PropInfo), PropType^,Reg);
tkClass:
{ sınıflar da alt sınıf olarak saklansın, özellikleri de bu anahtarın altına değer olarak yazılsın.}
SaveObjToRegistry(Name, TPersistent(GetOrdProp(Obj, PropInfo)),Reg);
tkMethod:
{ davranışlar isim olarak yazılsın. }
SaveMethodToRegistry(Name, GetMethodProp(Obj, PropInfo), Reg);
end;
end;
procedure TForm1.xxzzbtn1Click(Sender: TObject);
var
r:tregistry;
begin
r:=tregistry.create;
r.openkey('f1delphi\'+form1.name,true);
SaveToRegistry(form1, R);
r.free;
end;
end.
ListBox içerisinde artan arama
Bir listbox içerisinden seçilerek başka bir alana, örneğin bir edit kontrolüne atanacak değerlerin seçim için, artan arama yapılabilir. Artan arama , edit içerisine yazdığınız bilgiye uygun olan ListBox elemanının otomatik olarak seçili hale gelmesi demektir.
Kod örneği aşağıdadır.
unit incsearch;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Edit1: TEdit;
procedure FormCreate(Sender: TObject);
procedure Edit1Change(Sender: TObject);
procedure Edit1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
// ComboBox'un içine birşeyler doldurun
end;
procedure TForm1.Edit1Change(Sender: TObject);
var
S : Array[0..255] of Char;
begin
StrPCopy(S, Edit1.Text);
with ListBox1 do
ItemIndex := Perform(LB_SELECTSTRING, 0, LongInt(@S));
end;
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if key=vk_return then edit1.text:=listbox1.Items[listbox1.itemindex];
end;
end.
Sistem menüsünün geliştirilmesi
unit sysmenu;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes,
Graphics, Controls, Forms, Dialogs, Menus;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{Aşağıdaki tanım, mesaj yakalama yordamı içindir.
Yeni eklenen menü elemanına tıklandığının tespiti
için kullanılacaktır.}
procedure WinMsgHandler(var Msg : TMsg;
var Handled : Boolean);
end;
var
Form1: TForm1;
const
MyItem = 100; {Herhangi bir WORD değer olabilir.}
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
{Varolandan farklı bir mesaj yakalama yordamı kullanılacak}
Application.OnMessage := WinMsgHandler;
{Menüye Bir ayıraç ekleniyor.}
AppendMenu(GetSystemMenu(Self.Handle, False), MF_SEPARATOR, 0, '');
{Mevcut sistem menüsünün en sonuna,
Yeni menü ekleniyor}
AppendMenu(GetSystemMenu(Self.Handle, False), F_BYPOSITION, MyItem, 'Yeni &Menü');
end;
procedure TForm1.WinMsgHandler(var Msg : TMsg;
var Handled : Boolean);
begin
{Eğer mesaj, sistem mesajı ise...}
if Msg.Message=WM_SYSCOMMAND then
if Msg.wParam = MyItem then
{Menünüzün yapacağı işle ilgili kod buraya yazılacak}
ShowMessage('Yenü menüye tıkladınız!!!');
end;
end.
Bir Tedit.text bilgisindeki değişikliğin farkedilmesi
var
changed:boolean;
i:integer;
begin
changed:=false;
for i:=0 to componentcount-1 do
if components[i] is tedit then
changed:=(components[i] as tedit).modified;
if changed then showmessage('değişti');
end;
ComboBox bileşeninin, içine girildiğinde açılması ve kapanması
Sendmessage(combobox1.handle,cb_showdropdown,integer(true),0);
Sendmessage(combobox1.handle,cb_showdropdown,integer(false),0);
Yazıcıya doğrudan baskı gönderme işlemi
unit Esc1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
Printers;
{$R *.DFM}
{ "PASSTHROUGH" yapısını belirle }
type TPrnBuffRec = record
BuffLength : word;
Buffer : array [0..255] of char;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Buff : TPrnBuffRec;
TestInt : integer;
s : string;
begin
{ "PASSTHROUGH" işleminin desteklendiğinden emin ol }
TestInt := PASSTHROUGH;
if Escape(Printer.Handle,
QUERYESCSUPPORT,
sizeof(TestInt),
@TestInt,
nil) > 0 then
begin
{ Baskıyı başlat }
Printer.BeginDoc;
{ Doğrudan gönderilecek metni hazırla }
s := ' Test satırı ';
{ Mtni Buffer'a kopyala }
StrPCopy(Buff.Buffer, s);
{ Buffer uzunluğunu ayarla }
Buff.BuffLength := StrLen(Buff.Buffer);
{ Gönder}
Escape(Printer.Canvas.Handle,
PASSTHROUGH,
0,
@Buff,
nil);
{ Baskıyı bitir }
Printer.EndDoc;
end;
end;
end.
Bilgisayarı kapatıp yeniden başlatma
Bilgisayarı kapatıp, yeniden başlatmak için kullanılabilecek bir kod parçacığı aşağıdadır. Not : Bu kodu denemeden önce, dosyalarınızı kaydedin.
asm
cli
@@WaitOutReady: {Meşgul- 8042 yeni bir komut için hazır olana kadar bekle}
in al,64h {8042 durumunu oku}
test al,00000010b { 1 nolu bit veri giriş bufferinin dolu olduğunu gösterişri }
jnz @@WaitOutReady
mov al,0FEh { "reset" = 8042 pin 0 }
out 64h,al
{ PC kapanıp yeniden açılacak }
End;
]]>