Webmaster Araçları

Archive for the ‘Delphi’ Category

Delphi Kullanımında önemli noktalar

Cumartesi, Mayıs 2nd, 2009

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 ÜZERİNDE ARTTIRARAK ARAMA
TEdit kullanarak, TTable üzerinde arttırmalı arama yapmak için, Tedid bileşeninin OnChange olay yordamına, aş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 İÇERİSİNDE BİR METNİN ARANMASI
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.

BİR TABLONUN ALAN BİLGİLERİNİN ELDE EDİLMESİ
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.

TDBGRİD BİLEŞENİ ÜZERİNDE, KAYIT SIRALAMA
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 TABLODAKİ KOLONLARIN ELENMESİ

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;

BİR TABLODAKİ TMEMOFİELD TİPLİ BİR ALAN İÇERİĞİNİN
TMEMO BİLEŞENİNE AKTARILMASI

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;

BİR PARADOX TABLOSUNA İKİNCİ İNDEKS EKLENMESİ
Table1.AddIndex(’<indeks adı>’, ‘CustNo;CustName’,
[ixDescending]);
DBGrid kolonları üzerinde dolaşma
dbgrid1.selectedindex:=dbgrid1.selectedindex+1;
dbgrid1.setfocus;

DETAYI OLAN BİR TABLODAN KAYIT SİLME
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;

DBGRİD 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 İÇERİĞİNİN TSTRİNGRİD BİLEŞENİNE DOLDURULMASI
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 ÜZERİNDEN KAYIT NUMARASININ BULUNMASI
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. İndeks 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ılmamalı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 TABLOLARINDAN SİLİNMİŞ KAYITLARIN ATILMASI
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 İÇERİSİNDEN BDE KOD ADI (ALİAS) YARATILMASI
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 KOD ADI (ALİAS) PARAMETRELERİNİN ELDE EDİLMESİ
Session.GetAliasParams(’DBDEMOS’,listbox1.items);

BİR DBASE (.DBF) TABLOSUNDAKİ SİLİNMİŞ KAYITLARIN GÖRÜNTÜLENMESİ
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 TForm1.Button1Click(Sender: TObject);
begin
SetDelete(Table1, TRUE);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
SetDelete(Table1, False);
end;

end.

BİR TABLODAKİ ALAN SAYISININ BULUNMASI
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.

BİR TABLODAKİ VERİNİN, BAŞKA BİR TABLOYA EKLENMESİ
Aynı yapıdaki iki ayrı tablo 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 YARATILMASI
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 VERİ AKTARIMI
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;
TABLODAKİ BİR ALANA AİT VERİLERİN, BAŞKA BİR ALANA KOPYALANMASI
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ı fark etmez. 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 SİLME
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 ADININ BULUNMASI
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 İSİMLERİ
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;
TABLODAKİ ALAN İSİMLERİ
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 NUMARASI
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 TİPLERİ
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 ALANLARI
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ÖNTEMİYLE DEĞER SEÇME DİYALOĞ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;

BİR PARADOX TABLOSUNUN YENİDEN ANAHTARLANMASI
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 ADININ DEĞİŞTİRİLMESİ
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 YAPILARI AYNI MI?
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}

BİR TABLO ALANINDAKİ DEĞERLERİN SAĞ TARAFINDAKİ BOŞLUKLARIN TEMİZLENMESİ
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 MI?
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 MI?
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].Express
ion))>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 ANAHTARI VAR MI
Bu fonksiyon, belirtilen tablo, mevcutsa ve öncelikli anahtara sahipse 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 BİR TABLO İLE AYNI YAPIDA BAŞKA BİR 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 FİLTRELEME
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;

ŞİFRELİ PARADOX TABLOSUNA OTOMATİK BAĞLANTI
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.
SUBSTRİNG FONKSİYONUNUN SQL CÜMLESİNDE KULLANILMASI
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)

DBCONTROLGRİD KAYDIRMA ÇUBUKLARI
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 BİR DBGRİD
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;

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.CalendarD
ate);
end;
2:{- ay}begin
takvim.prevmonth;

takvimedit.text:=FormatDateTime(’DD.MM.YYYY’,takvim.CalendarD
ate);
end;
3:{+ yıl}begin
takvim.nextmonth;

takvimedit.text:=FormatDateTime(’DD.MM.YYYY’,takvim.CalendarD
ate);
end;
4:{+ ay} begin
takvim.nextyear;

takvimedit.text:=FormatDateTime(’DD.MM.YYYY’,takvim.CalendarD
ate);
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.

AĞ İŞLEMLERİ

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 TANIMLI KULLANICILAR KİMLER?
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}

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.

SES VE GRAFİK İŞLEMLERİ

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(Clien
tHeight*((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;

BİR RESMİ, BMP FORMATINDAN JPEG FORMATINA ÇEVİRME

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ĞIDI DEĞİŞTİRME
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;

SİSTEMİN KULLANABİLECEĞİ RENK SAYISININ BULUNMASI
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;

DBGRİD ALANLARININ RENKLENDİRİLMESİ
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;

LİSTBOX BİLEŞENLERİNDE RENKLİ SATIRLAR
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 PALETLERİNİN YARATILMASI VE KULLANIMI
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.
•    Formun GetPalette davranışı,yeni paleti döndürecek şekilde değiştirilmelidir.
•    Boyamaya başlamadan hemen önce, yeni palet seçilmelidir.
OldPal := SelectPalette(Canvas.Handle, NewPalette, False);
RealizePalette(Canvas.Handle);
SelectPalette(Canvas.Handle, OldPal, False);
•    İşlem tamamlandıktan sonra palet yok edilmelidir.
•    Renk değeri almak için, RGB fonksiyonu yerine PaletteRGB fonksiyonu kullanılmalıdır.

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ÜZİK CD Sİ ÇALINIRKEN, TRACK SAYISININ OKUNMASI
Ç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ĞİŞTİRME
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 RESMİNİN PANOYA YAPIŞTIRILMSI VE PANODAN KOPYALAMASI
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

BİR EXE DEKİ İKONUN ALINP BAŞKA BİR YERE ÇİZİLMESİ
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 RESMİNİN, BUTON ÜZERİNDE KULLANILMASI
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 RESİM 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;

BİR RESMİN ŞEFFAF OLARAK BAŞKA BİR RESİM ÜZERİNE YAPIŞTIRILMASI
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ĞİŞTİRME
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

PANODAKİ METNİN DİSKTEKİ BİR DOSYAYA KAYDEDİLMESİ
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.

FORM VE PENCERE İŞLEMLERİ
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ÇIK PENCERELERİN LİSTELENMESİ
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;

FARKLI BİR 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.

ÜZERİNE BIRAKILAN DOSYALARA DUYARLI 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ŞLIĞININ SAKLANMASI
procedure TForm1.Createparams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
Style := (Style or WS_POPUP) and (not
WS_DLGFRAME);
end;
STANDART DIŞI 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 800×600 ö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ŞLIK ALANI ÜZERİNDE SAAT GÖSTERİLMESİ
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ŞLIĞININ GİZLENMESİ
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ŞLIK ALANINA BUTON YERLEŞTİRME
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ÇILIR-KAPANIR 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.

PENCERENİN TAŞINMASI
Windows pencereleri, ekran üzerinde başlıklarından tutularak taşınırlar. Pencere alanından tutularak 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;

DİSKET SÜRÜCÜSÜNDE DİSKET TAKILI MI ?
{$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;

ÇALIŞAN UYGULAMANIN BULUNDUĞU DİZİN
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;

WİNDOWS’UN STANDART “BROWSEFOLDER” DİYALOG PENCERESİNİN KULLANILMASI
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ÇİLEBİLECEK, DİĞER ÖZEL KLASÖR TİPLERİ
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 ŞABLONLARI
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 BİR KOPYALAMA YÖNTEMİ;
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;

İKİLİ 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.}

BİR DOSYANIN SALT OKUNUR OLARAK AÇILMASI
Assignfile satırından sonra dosya açma modu belirtilmelidir.

AssignFile(F, FileName);
FileMode := 0; ( Salt okunur }
Reset(F);
CloseFile(F);

SATIR SONU KARAKTERİNİN ASCİİ KODU NEDİR?
Control-Z, veya 26 numaralı ASCII karakteri

DİSK SERİ NUMARASI VE ETİKETİNİN OKUNMASI
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.

DİSK SERİ NUMARASINA ERİŞİMİN BAŞKA BİR 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.

DİSK BİLGİLERİNİ ELDE ETMENİN BİR DİĞER YOLU İSE;
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;

BİR DOSYANIN TARİH VE SAAT BİLGİSİNİN ALINMASI
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;

BİR KLASÖRÜN ÖZELLİĞİNİN DEĞİŞTİRİLMESİ
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;

DOSYANIN SÜRÜKLENİP BIRAKILMASI
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

procedure AcceptFiles( var msg : TMessage );
message WM_DROPFILES;
end;

var
Form2: TForm2;

implementation

uses
ShellAPI;

{$R *.DFM}

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.

WİNDOWS GEÇİCİ KLASÖRÜNÜN BULUNMASI
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 YARATILMA TARİHİ
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;

DOSYANIN SON KULLANILDIĞI TARİH
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,D
T);
FileTimeToSystemTime(DT, ST);
Result := SystemTimeToDateTime(ST);
Finally
SysUtils.FindClose(SearchRec);
End;
Except
Result := 0;
End;
end;

DOSYANIN SON DEĞİŞTİRİLDİĞİ TARİH
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;

DİZİN 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 UZANTISI HANGİ PROGRAMLA BAĞLANTILI?
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.

GERİ 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:\&quotWP.txt’);
end;

end.

GENEL

Bu bölümde, diğer başlıklar altında yer almayan püf noktaları ve kod örnekleri yer almaktadır.

KARAKTER DİZİSİ KARŞILAŞTIRMA
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ÜKLENMİŞ DLL DOSYALARININ HAFIZADAN ATILMASI
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;

BİR DOS KOMUTUNUN KULLANILMASI
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;

TEDİT METNİNİN, ONCHANGE OLAYINDA DEĞİŞTİRİLMESİ
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 BİLEŞENİNDE, İMLEÇ HANGİ SATIRDA?
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’;

TEDİTBOX BİLEŞENİNDEKİ METNİN İLK KARAKTERİNİN, BÜYÜK HARFE ÇEVİRİLMESİ
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;

WİNDOWS’UN KAPANMA ANININ TESPİTİ
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;

WİNDOWSUN KAPANDIĞINI TESPİT EDEN BİR BİLEŞEN KODU AŞAĞIDADIR.
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.

BİR MEMO VEYA RİCHEDİT BİLEŞENİNDE, İMLECİN İSTENEN YERE GÖNDERİLMESİ
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;

OTOMATİK E-MAİL

//uses satırına shellapi eklenmeli
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute(Handle,’open’,'mailto:fdemirel@kkk.tsk.mil.tr’,’
‘,”,sw_Normal);
end;

MONİTÖRÜN AÇILIP KAPATILMASI
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;

WİNDOWS’UN KAPATILMASI/YENİDEN BAŞLATILMASI
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;

SİSTEMDE SES KARTI VARMI?
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’);

PROGRAMIN ARKA PLANDA ÇALIŞTIRILMASI
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;

ÇALIŞAN PROGRAMIN, GÖREV ÇUBUĞU ÜZERİNDEN KALDIRILMASI
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’KULLANIMI
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ÜĞÜNDEKİ DEĞİŞİKLİKLERİN TESPİTİ
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 BİLGİLERİ
Bilgisayardaki mikro işlemcinin tipinin ve üreticisinin tespit 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 6×86′;
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 Am5×86′;
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 YERİNE KULLANILABİLECEĞİ BİR TEDİT BİLEŞENİ
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 HAFTANIN İLK 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;

SONRAKİ HAFTANIN İLK 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;

AYIN 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;

ÖNCEKİ 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;

METİN İÇERİSİNDEN BİR KARAKTER SİLME
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;

METİN İÇERİSİNDEN, BİR KARAKTERİ DEĞİŞTİRME
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;

BİR METNİ BELLİ BİR 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;

METİN DEĞİŞTİRME
Function String_Replace(
OldSubString : String;//atılacak metin
NewSubString : String;//atılanın yerine konacak metin
SourceString : String): String;//üzerinde değ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 İÇERİSİNDEN BAŞKA BİR 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);

PROGRAMI DENEME SÜRÜMÜ HALİNE GETİRME
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 oturumunda 1
kez çalışır.’+crlf+’+
Windows’u yeniden başlatın.’+crlf+
‘Ya da bizi arayıp satın alın’);
Close;
end;
end;

LİSTBOX BİLEŞENİNE YATAY KAYDIRMA ÇUBUĞU EKLENMESİ
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

SİSTEM TARİH/SAAT AYARININ DEĞİŞTİRİLMESİ
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Ş KOMBİNASYONLARININ KULLANIMA KAPATILMASI
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 ÇIKARILMASI
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;

PROGRAMIN, WİNDOWSUN BAŞLANGICINDA ÇALIŞTIRILMASI
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 MESAJI 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 KURULMASI
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;

LİSTBOX YAZI TİPİNİN DEĞİŞTİRİLMESİ
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ŞINABİLİR 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ĞININ KAPATILMASI
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);

ÇALIŞMA ESNASINDA, BİLEŞEN SAYISININ 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 İMLECİNİN, İSTENEN KONTROL ÜZERİNE GETİRİLMESİ
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Ş KOMBİNASYONU
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.

PROGRAMIN DURAKLATILMASI
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.

YAZI KARAKTERİ STİLİNİN DEĞİŞTİRİLMESİ
with edit1 do
begin
Font.Style := Font.Style + [fsStrikeOut];
Font.Style := Font.Style + [fsUnderline];
Font.Style := Font.Style - [fsBold];
end;

MEVCUT BİR DAVRANIŞIN DEĞİŞTİRİLMESİ
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ŞTIR
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 PARAMETRESİNİN KULLANILMASI
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 METİNLERİN PANODAN ALINMASI
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);

WİNDOWS SÜRÜM NUMARASININ OKUNMASI
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 GURUPLARININ LİSTBOX BİLEŞENİNE DOLDURULMASI
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

TLİSTBOX VE TCOMBOBOX BİLEŞENLERİ İÇERİSİNE RESİM YERLEŞTİRİLMESİ
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

BASİT BİR 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 PENCERESİNİN ÖZELLEŞTİRİLMESİ
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));

STRİNGRİD BİLEŞENİ İÇERİSİNDEKİ METNİN HİZALAMASI
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.

TSTRİNGGRİD BİLEŞENİNDEN BİR SATIRIN SİLİNMESİ
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;

TSTRİNGGRİD SATIRININ EN ALTA GÖNDERİLMESİ
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;

YAZDIRMA
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;

İSTENEN YAZICININ SEÇİMİ
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;

YAZICI YAZI TİPLERİ
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 TO 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;

HAFIZA MİKTARI
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 ALANININ KISITLANMASI
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ŞLARI İLE FORMU AŞAĞI YUKARI KAYDIRMA
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 YAZI KARAKTERİ
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.

BİR NESNEDEKİ ÖZELLİKLERİN LİSTESİ
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 PORTLARINA ERİŞİM
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;

BİLEŞEN ÖZELLİKLERİNİN KAYIT DEFTERİNDE SAKLANMASI
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.

LİSTBOX İÇERİSİNDE 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.

BİR TEDİT.TEXT BİLGİSİNDEKİ DEĞİŞİKLİĞİN FARKEDİLMESİ
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 BİLEŞENİNİN, İÇİNE GİRİLDİĞİNDE AÇILMASI VE KAPANMASI
Sendmessage(combobox1.handle,cb_showdropdown,integer(true),0);
Sendmessage(combobox1.handle,cb_showdropdown,integer(false),0);

YAZICIYA DOĞRUDAN BASKI GÖNDERME İŞLEMİ
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.

BİLGİSAYARI KAPATIP YENİDEN 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;

Tags: AĞ IŞLEMLERI, AND WINDOW PROCESSING FORM, AUDIO AND GRAPHICS OPERATIONS, Database / BDE, Disk and File Processing, DİSK VE DOSYA İŞLEMLERİ, FORM VE PENCERE IŞLEMLERI, NEETWORK, Network Processing, SES VE GRAFİK İŞLEMLERİ, VERİ TABANI/BDE
Posted in Delphi | No Comments »

Delphi kullanarak MS-Access Veri Tabanının Sıkıştırılması - Onarılması

Cumartesi, Mayıs 2nd, 2009

# MS-Access veri tabanını uygulama içinde sıkıştırmaya ve onarmaya yarıyor.
# MS-Access data base and to repair injuries to the application is the compression.
# D6-BDS2006-CG2007

PHP Kodu:

  CompactAndRepair(sOldMDB : String; sNewMDB : String) : Boolean;

const

sProvider = ‘Provider=Microsoft.Jet.OLEDB.4.0;’;

var

oJetEng : JetEngine;

begin

sOldMDB := sProvider + ‘Data Source=’ + sOldMDB;

sNewMDB := sProvider + ‘Data Source=’ + sNewMDB;
try

oJetEng := CoJetEngine.Create;

oJetEng.CompactDatabase(sOldMDB, sNewMDB);

oJetEng := Nil;

Result := True;

except

oJetEng := Nil;

Result := False;

end;

end;

if CompactAndRepair(‘e:\Old.mdb’, ‘e:\New.mdb’) then ShowMessage(‘İşlem Başarılı.’) else ShowMessage(‘İşlemde Hata Oluştu.’);

# Önemli Not:
1- JRO_TLB unit ini uses bölümüne ekleyin.
2- Database sıkıştırılırken kimse database i açıp kullanmamalıdır.
3- Eðer JRO_TLB unit i ile ilgili Delphi hata verirse aşağıdakileri yapın
a) Delphi menüsünde Project - Import Type Library i seçin
b) “Microsoft Jet and Replication Objects 2.1 Library” i bulun.
c) Install butonunu tıklayın.
d) Programınızı tekrar derleyin

# Important Note:
1 - JRO_TLB unit will add to the uses section.
2 - Database compression are open and i should not use one database.
3 - If i JRO_TLB unit gives the following error related to Delphi
a) Delphi menu Project - Select Import Type Library
b) “Microsoft Jet and Replication Objects 2.1 Library” i found.
c) Click the Install button.
d) Compile your program again

Tags: Delphi, MS-Access, rar, skıştırmak, zip
Posted in Delphi | No Comments »

Webmaster Araçları

Webmaster Yardım ve Bilgi Bloğu

Categories

Archives

Archive for the ‘Delphi’ Category

Delphi Kullanımında önemli noktalar

Delphi kullanarak MS-Access Veri Tabanının Sıkıştırılması - Onarılması

Posts by Category

Google

Internet

Web 2.0

Web Development

Recent

Articles

Tag Cloud

DMOZ

Pages