Programlama yapalım ve Öğrenelim.

Özel bir DBGrid

Tarih alanlarına veri girişi herzaman problemdir. Bilgisayarların tarih formatları farklı olabileceği gibi, kullanıcıların tarih kullanma alışkanlıklarındaki farklılıklar da, veri tabanına tarih girişi işlemlerinde, hata mesajlarına sebep olur.

Aşağıdaki bileşen, DBGrid bileşeninden türetilmiş olup, Tarih alanına çift tıklandığında, otomatik olarak açılan bir takvimden seçim yapmak suretiyle bilgi girişini sağlamaktadır.

unit ExtDbGrid;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs,Db, DBTables,buttons, StdCtrls, DBGrids,ComCtrls, WinTypes,

WinProcs, ExtCtrls, Menus, Calendar,DBCtrls;

const

Tdatefieldtype=9;

type

TExtDbGrd = class(TDBGrid)

private

{ Private declarations }

f_message:string;

f_about:string;

protected

{ Protected declarations }

public

{ Public declarations }

published

property About:string read f_about write f_about;

procedure DblClick;override;

procedure Takvimyap;

procedure Takvimkapat;

procedure mybtnclick(sender:tobject);

constructor create(aowner:tcomponent);override;

destructor destroy;override;

{ Published declarations }

end;

implementation

{$R *.RES}

var

takvimform:tform;

takvimpanel:tpanel;

takvim:tcalendar;

takvimbtn:array [1..6] of tspeedbutton;

takvimedit:tedit;

msgid:integer;

oneinstance:boolean;

constructor TExtDbGrd.create(aowner:tcomponent);

begin

inherited;

color:=clyellow;

font.color:=clblue;

about:='Written by Faruk DEMİREL (fdemirel@kkk.tsk.mil.tr) 01.02.1998 Turkey';

end;

destructor TExtdbgrd.destroy;

begin

inherited;

end;

procedure TExtDbGrd.dblclick;

begin

inherited;

if not oneinstance then

begin

if ord(fields[selectedindex].datatype)=11 then

SHOWMESSAGE('TarihSaat tipindeki alanlarda takvim açılmaz');

if (ord(fields[selectedindex].datatype)=TdateFieldType) then

begin

oneinstance:=true;

takvimyap;

takvim.calendardate:=strtodate(fields[selectedindex].asstring);

end;

procedure TEXTDBGRD.Takvimyap;

var

i:integer;

begin

takvimform:=tform.create(self);

takvimform.width:=267;

takvimform.height:=195;

takvimform.borderstyle:=bstoolwindow;

takvimform.formstyle:=fsstayontop;

takvimform.visible:=false;

takvimform.BORDERICONS:=[];

{takvim paneli}

takvimpanel:=tpanel.create(self);

takvimpanel.width:=250;

takvimpanel.height:=160;

takvimpanel.parent:=takvimform;

takvimpanel.left:=5 ;

takvimpanel.top:=5;

{takvim}

takvim:=tcalendar.create(takvimpanel);

takvim.parent:=takvimpanel;

takvim.left:=10;

takvim.top:=10;

takvim.width:=200;

takvim.color:=color;

takvim.font.color:=font.color;

{takvim butonları}

for i:=1 to 6 do

begin

takvimbtn[i]:=tspeedbutton.create(self);

takvimbtn[i].parent:=takvimpanel;

takvimbtn[i].left:=215;

takvimbtn[i].width:=25;

takvimbtn[i].height:=22;

takvimbtn[i].top:=10+25*(i-1);

takvimbtn[i].onclick:=mybtnclick;

takvimbtn[i].tag:=i;

takvimbtn[i].showhint:=true;

end;

takvimbtn[1].GLYPH.Handle := LoadBitmap(HInstance,'PY');

takvimbtn[1].hint:='Önceki Yıl';

takvimbtn[2].GLYPH.Handle := LoadBitmap(HInstance,'PM');

takvimbtn[2].hint:='Önceki Ay';

takvimbtn[3].GLYPH.Handle := LoadBitmap(HInstance,'NM');

takvimbtn[3].hint:='Sonraki Ay';

takvimbtn[4].GLYPH.Handle := LoadBitmap(HInstance,'NY');

takvimbtn[4].hint:='Sonraki Yıl';

takvimbtn[5].GLYPH.Handle := LoadBitmap(HInstance,'CHOOSE');

takvimbtn[5].hint:='Seç';

takvimbtn[6].GLYPH.Handle := LoadBitmap(HInstance,'QUIT');

takvimbtn[6].hint:='Çık';

{takvim editi}

takvimedit:=tedit.create(self);

takvimedit.parent:=takvimpanel;

takvimedit.left:=75 ;

takvimedit.top:=130;

takvimedit.width:=70;

takvimedit.text:=datetostr(takvim.calendardate);

takvimedit.readonly:=true;

takvimform.formstyle:=fsstayontop;

takvimform.visible:=true;

takvimform.show;

end;

procedure TExtDbGrd.Takvimkapat;

var

i:integer;

begin

for i:=1 to 5 do takvimbtn[i].free;

takvim.free;

takvimedit.free;

takvimpanel.free;

takvimform.visible:=false;

takvimform.Free;

oneinstance:=false;

end;

procedure TExtDbGrd.mybtnclick(sender:tobject);

begin

case (sender as tspeedbutton).tag of

1:{- yıl}begin

takvim.prevyear;

takvimedit.text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarDate);

end;

2:{- ay}begin

takvim.prevmonth;

takvimedit.text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarDate);

end;

3:{+ yıl}begin

takvim.nextmonth;

takvimedit.text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarDate);

end;

4:{+ ay} begin

takvim.nextyear;

takvimedit.text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarDate);

end;

5:{kapat}begin

datasource.dataset.edit;

text:=FormatDateTime('DD.MM.YYYY',takvim.CalendarDate);

fields[selectedindex].value:=text;

datasource.dataset.post

end;

6:{İptal}begin

takvimkapat;

end;

initialization

oneinstance:=false;

end.

DBNavigator butonlarına erişim

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls, DBCtrls, DBNavigator1;

type

TForm1 = class(TForm)

DBNavigator1: TDBNavigator;

Button1: TButton;

DBNavigator11: TDBNavigator1;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

begin

DBNavigator11.setbuttonenabled(nbfirst);

end;

end.

2. Ağ işlemleri

Bu bölümde, Delphi uygulamalarında gerekebilecek, ağ uygulamaları ve ağ erişimleri ile ilgili püf noktaları ve kod örnekleri yer almaktadır.

Ağ sürücüleri

Sistemde tanımlı olan ağ sürücülerinin listesini elde etmek için aşağıdaki fonksiyon kullanılabilir.

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

ListBox1: TListBox;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function GetNetworkDriveMappings(

sl : TStrings ) : integer;

var

i : integer;

sNetPath : string;

dwMaxNetPathLen : DWord;

begin

sl.Clear;

dwMaxNetPathLen := MAX_PATH;

SetLength( sNetPath,

dwMaxNetPathLen );

for i := 0 to 25 do

begin

if( NO_ERROR =

Windows.WNetGetConnection(

PChar(

'' + Chr( 65 + i ) + ':' ),

PChar( sNetPath ),

dwMaxNetPathLen ) )then

begin

sl.Add( Chr( 65 + i ) + ': ' +

sNetPath );

end;

Result := sl.Count;

end;

procedure TForm1.Button1Click(Sender: TObject);

// here's how to call GetNetworkDriveMappings():

var

sl : TStrings;

nMappingsCount,

i : integer;

begin

sl := TStringList.Create;

nMappingsCount :=

GetNetworkDriveMappings( sl );

for i := 0 to nMappingsCount-1 do

begin

//İstenen şeyler burada yapılabilir.

// Şimdilik sadece görüntülensin

MessageBox( 0,

PChar( sl.Strings[ i ] ),

'Tanımlı Ağ diskleri',MB_OK );

end;

listbox1.items.assign(sl);

sl.Free;

end;

end.

Ağ da tanımlı kullanıcılar kimler?

Ağ ortamındayken, aynı ağa giriş yapmaya yetkili kullanıcıların (bilgisayarların), isimlerini bulup getiren bir bileşene ait unit aşağıdadır.

Kullanılabilmesi için, sisteme bileşen olarak tanımlanması gereklidir. Bunun için, Components | Install components menüsü kullanılır.

unit NetUsers;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type

TNetUsers = class(TComponent)

private

{ Private declarations }

fServer : String;

protected

{ Protected declarations }

Procedure SetServer(Server : String);

public

{ Public declarations }

UserList: TStringList;

Constructor Create(Owner:TComponent); override;

Destructor Destroy; override;

Function Execute : Boolean;

published

{ Published declarations }

property Server :String read fServer write SetServer;

end;

PnetResourceArr = ^TNetResource;

procedure Register;

implementation

Procedure TNetUsers.SetServer(Server : String);

Begin

If fServer <> Server Then

fServer := Server;

End;

Constructor TNetUsers.Create(Owner:TComponent);

Begin

Inherited Create(Owner);

If Not ( csDesigning in ComponentState ) Then

Begin

UserList := TStringList.Create;

UserList.Sorted := True;

End;

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;

Res := WNetCloseEnum(lphEnum);

If Res <> 0 then Raise Exception(Res);

Finally

FreeMem(Buf);

Execute := True;

End;

procedure Register;

begin

RegisterComponents('Sil', [TNetUsers]);

end;

end.

//kullanımı

{

procedure TForm1.Button1Click(Sender: TObject);

begin

NETUSERS1.EXECUTE;

listbox1.items.assign(netusers1.userlist)

end;}

Tanımlı ağ sürücüleri

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

ListBox1: TListBox;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function GetNetworkDriveMappings(

sl : TStrings ) : integer;

var

i : integer;

sNetPath : string;

dwMaxNetPathLen : DWord;

begin

sl.Clear;

dwMaxNetPathLen := MAX_PATH;

SetLength( sNetPath,

dwMaxNetPathLen );

for i := 0 to 25 do

begin

if( NO_ERROR =

Windows.WNetGetConnection(

PChar(

'' + Chr( 65 + i ) + ':' ),

PChar( sNetPath ),

dwMaxNetPathLen ) )then

begin

sl.Add( Chr( 65 + i ) + ': ' +

sNetPath );

end;

Result := sl.Count;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

sl : TStrings;

nMappingsCount,

i : integer;

begin

sl := TStringList.Create;

nMappingsCount :=

GetNetworkDriveMappings( sl );

for i := 0 to nMappingsCount-1 do

begin

MessageBox( 0,

PChar( sl.Strings[ i ] ),

'Network sürücü tanımları',

MB_OK );

end;

listbox1.items.assign(sl);

sl.Free;

end;

end.

3. Ses ve Grafik işlemleri

Bu bölümde, delphi uygulamalarında yapılabilecek ses ve grafik işlemleri ile ilgili püf noktaları ve kod örnekleri yer almaktadır.

Farklı çizgiler

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

procedure FormPaint(Sender: TObject);

public

DrawNow : Integer;

end;

var

Form1: TForm1;

procedure DrawPoint(x,y : Integer;lpData : LParam); stdcall;

implementation

{$R *.DFM}

procedure DrawPoint(x,y : Integer;lpData : LParam);

begin

with TObject(lpData) as TForm1 do begin

if DrawNow mod 4 = 0 then

Canvas.Rectangle(x-2,y-2,x+3,y+3);

Inc(DrawNow);

end;

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;

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 = (

40)

RowHeights = (

12)

end

Tonlamalı(Gradient) Form

procedure TForm1.FormPaint(Sender: TObject);

const N=100;

var Y:Integer;

Cl:TColor;

begin

for Y:=0 to N-1 do

with Canvas do

begin

Cl:=RGB(0,0,Round(50+205*(Y/N)));

Pen.Color:=Cl;

Brush.Color:=cl;

Rectangle(0,Round(ClientHeight*(Y/N)),ClientWidth,Round(ClientHeight*((Y+1)/N)));

end;

procedure TForm1.FormResize(Sender: TObject);

begin

Invalidate;

end;

Ekran yakalama

Masaüstü görüntüsünün yakalanıp, form üzerine aktarılması;

procedure Tform1.GrabScreen;

var

DeskTopDC: HDc;

DeskTopCanvas: TCanvas;

DeskTopRect: TRect;

begin

DeskTopDC := GetWindowDC(GetDeskTopWindow);

DeskTopCanvas := TCanvas.Create;

DeskTopCanvas.Handle := DeskTopDC;

DeskTopRect := Rect(0,0,Screen.Width,Screen.Height);

Canvas.CopyRect(DeskTopRect,DeskTopCanvas,DeskTopRect);

ReleaseDC(GetDeskTopWindow,DeskTopDC);

end;

veya;

var width, height : word;

desktop : HDC;

begin

width := Screen.Width;

height := Screen.Height;

desktop := GetWindowDC(GetDesktopWindow);

Image1.Picture.Bitmap.Width := width;

Image1.Picture.Bitmap.Height := height;

BitBlt( Image1.Picture.Bitmap.Canvas.Handle, 0, 0,

width, height, desktop, 0, 0, SRCCOPY );

end;

Bir resmi, Bmp formatından Jpeg formatına çevirme

var bmp : TImage;

jpg : TJpegImage;

begin

bmp := TImage.Create(nil);

jpg := TJpegImage.Create;

bmp.picture.bitmap.LoadFromFile ( 'c:picture.bmp' );

jpg.Assign( bmp.picture.bitmap );

jpg.SaveToFile ( 'c:picture.jpg' );

jpg.Free;

bmp.Free;

end;

Duvar kağıdı değiştirme

Programınızın çalışması esnasında, arzu ettiğiniz bir duvar kağıdının kullanılmasını ister misiniz? İşte bunu halletmenin yolu…

procedure TForm1.FormCreate(Sender: TObject);

var

Reg: TRegIniFile;

begin

Reg := TRegIniFile.Create('Control Panel');

Reg.WriteString('desktop', 'Wallpaper',

'c:windowsforest.bmp');

Reg.WriteString('desktop', 'TileWallpaper', '1');

Reg.Free;

SystemParametersInfo(SPI_SETDESKWALLPAPER,0, nil, SPIF_SENDWININICHANGE);

end;

Sistemin kullanabileceği renk sayısının bulunması

Garfik işlemleri yaparken, sistemde geçerli olan renk ayarına ihtiyaç olabilir. Aşağıdaki fonksiyon sistemin desteklemekte olduğu renk sayısını bulmaktadır.

function GetColorsCount : integer;

var

h : hDC;

begin

Result := 0;

try

h := GetDC( 0 );

Result :=1 shl (GetDeviceCaps(h, PLANES) *

GetDeviceCaps(h, BITSPIXEL));

finally

ReleaseDC( 0, h );

end;

DbGrid alanlarının renklendirilmesi

TDBGrid bileşeninde gösterilen bilginin, daha kolay okunabilmesi, ve kullanıcının dikkatinin bazı özel durumlara çekilebilmesi için, hücreleri renklendirmek faydalı olabilir.

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect:

TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);

var

holdColor: TColor;

begin

holdColor := DBGrid1.Canvas.Brush.Color if Column.FieldName = 'EmpNo' then

if (Column.Field.AsInteger mod 2 0) then begin

DBGrid1.Canvas.Brush.Color := clGreen;

DBGrid1.DefaultDrawColumnCell(Rect, DataCol, Column, State);

DBGrid1.Canvas.Brush.Color := holdColor;

end;

ListBox bileşenlerinde Renkli satırlar

Bir Tlistbox içerisinde bulunan satırların, belli şartlara göre farklı renklerde olması mümkündür. Aşağıdaki kod örneğinde bunun yapılışı gösterilmektedir. Dikkat edilmesi gereken en önemli husus, Listbox bileşeninin Style özelliği lbOwnerDrawFixed olmalıdır.

//Style= lbOwnerDrawFixed olmalı…

procedure TForm1.ListBox1DrawItem(Control: TWinControl;

Index: Integer; Rect: TRect; State: TOwnerDrawState);

begin

With ( Control As TListBox ).Canvas Do

Begin

Case Index Of

Begin

Font.Color := clBlue;

Brush.Color := clYellow;

End;

Begin

Font.Color := clRed;

Brush.Color := clLime;

End;

Begin

Font.Color := clGreen;

Brush.Color := clFuchsia;

End;

FillRect(Rect);

TextOut(Rect.Left, Rect.Top, ( Control As TListBox ).Items[Index]);

End;

end;