Programlama yapalım ve Öğrenelim.

İkon resminin, buton üzerinde kullanılması

Not : image bileşenlerinin picture bilgileri, silinmiştir.

object Form1: TForm1

Left = 200

Top = 108

Width = 278

Height = 372

Caption = 'Form1'

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

PixelsPerInch = 96

TextHeight = 13

object SpeedButton1: TSpeedButton

Left = 8

Top = 16

Width = 65

Height = 57

end

object FileListBox1: TFileListBox

Left = 80

Top = 16

Width = 169

Height = 313

ItemHeight = 13

TabOrder = 0

OnClick = FileListBox1Click

end

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.

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;

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;

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

Panoya resim kopyalama

bütün formu panoya kopyalar

procedure TForm1.Button2Click(Sender: TObject);

//uses clipbrd

Var

Image : TImage;

BitMap : TBitmap;

Begin

Image:=TImage.Create(Self);

BitMap:=TBitMap.Create;

BitMap.Width:=ClientWidth;

BitMap.Height:=ClientHeight;

BitBlt(BitMap.Canvas.Handle, 0, 0, ClientWidth, ClientHeight, GetDC(Handle),

0, 0, SRCCOPY);

Image.Picture.Graphic:=BitMap;

Clipboard.Assign(Image.Picture);

BitMap.Free;

Image.Free

end;

Bir remin şeffaf olarak başka bir resim üzerine yapıştırılması

Unit1.pas

unit Unit1;

interface

uses

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

ExtCtrls, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Image1: TImage;

ColorDialog1: TColorDialog;

Panel1: TPanel;

Button2: TButton;

Image2: TImage;

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

procedure DrawTransparent(t: TCanvas; x,y: Integer; s: TBitmap; TrCol: TColor);

end;

var

Form1: TForm1;

bmp:tbitmap;

clr:tcolor;

implementation

{$R *.DFM}

procedure tform1.DrawTransparent(t: TCanvas; x,y: Integer; s: TBitmap; TrCol: TColor);

var

bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap;

oldcol: Longint;

begin

try

bmpAND := TBitmap.Create;

bmpAND.Width := s.Width;

bmpAND.Height := s.Height;

bmpAND.Monochrome := True;

oldcol := SetBkColor(s.Canvas.Handle, ColorToRGB(TrCol));

BitBlt(bmpAND.Canvas.Handle, 0,0,s.Width,s.Height, s.Canvas.Handle, 0,0, SRCCOPY);

SetBkColor(s.Canvas.Handle, oldcol);

bmpINVAND := TBitmap.Create;

bmpINVAND.Width := s.Width;

bmpINVAND.Height := s.Height;

bmpINVAND.Monochrome := True;

BitBlt(bmpINVAND.Canvas.Handle, 0,0,s.Width,s.Height, bmpAND.Canvas.Handle, 0,0, NOTSRCCOPY);

bmpXOR := TBitmap.Create;

bmpXOR.Width := s.Width;

bmpXOR.Height := s.Height;

BitBlt(bmpXOR.Canvas.Handle, 0,0,s.Width,s.Height, s.Canvas.Handle, 0,0, SRCCOPY);

BitBlt(bmpXOR.Canvas.Handle, 0,0,s.Width,s.Height, bmpINVAND.Canvas.Handle, 0,0, SRCAND);

bmpTarget := TBitmap.Create;

bmpTarget.Width := s.Width;

bmpTarget.Height := s.Height;

BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, t.Handle, x,y, SRCCOPY);

BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, bmpAND.Canvas.Handle, 0,0, SRCAND);

BitBlt(bmpTarget.Canvas.Handle, 0,0,s.Width,s.Height, bmpXOR.Canvas.Handle, 0,0, SRCINVERT);

BitBlt(t.Handle, x,y,s.Width,s.Height, bmpTarget.Canvas.Handle, 0,0, SRCCOPY);

finally

bmpXOR.Free;

bmpAND.Free;

bmpINVAND.Free;

bmpTarget.Free;

end;{End of TRY section}

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

DrawTransparent(image1.Canvas, 1,1, bmp, clr);

image1.Invalidate;

image1.repaint;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

bmp:=tbitmap.create;

bmp.width:=image1.width;

bmp.height:=image1.height;

bmp.assign(image2.picture);

// clr:=tcolor.create;;

clr:=clgreen;

panel1.color:=clr;

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

bmp.free;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

if colordialog1.execute then

clr:=colordialog1.Color;

panel1.color:=clr;

end;

end.

Unit1.dfm

object Form1: TForm1

Left = 200

Top = 108

Width = 617

Height = 302

Caption = 'Form1'

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OnCreate = FormCreate

OnDestroy = FormDestroy

PixelsPerInch = 96

TextHeight = 13

object Image1: TImage

Left = 264

Top = 8

Width = 329

Height = 201

Stretch = True

end

object Image2: TImage

Left = 8

Top = 8

Width = 249

Height = 201

Stretch = True

end

object Button1: TButton

Left = 144

Top = 224

Width = 75

Height = 25

Caption = 'Button1'

TabOrder = 0

OnClick = Button1Click

end

object Panel1: TPanel

Left = 304

Top = 216

Width = 113

Height = 41

Caption = 'Panel1'

TabOrder = 1

object Button2: TButton

Left = 22

Top = 8

Width = 75

Height = 25

Caption = 'Button2'

TabOrder = 0

OnClick = Button2Click

end

object ColorDialog1: TColorDialog

Ctl3D = True

Left = 112

Top = 352

end

Palet değiştirme

Palet.pas

unit palet;

interface

uses

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

StdCtrls, ComCtrls, ExtDlgs;

type

TForm1 = class(TForm)

Button1: TButton;

OpenPictureDialog1: TOpenPictureDialog;

SavePictureDialog1: TSavePictureDialog;

Button2: TButton;

Button3: TButton;

procedure FormCreate(Sender: TObject);

procedure FormPaint(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

procedure ScrambleBitmap;

end;

var

Form1: TForm1;

bitmap:tbitmap;

pal: PLogPalette;

implementation

{$R *.DFM}

procedure Tform1.ScrambleBitmap;

var

hpal: HPALETTE;

i: Integer;

begin

{$R-}

pal := nil;

try

GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);

pal.palVersion := $300;

pal.palNumEntries := 256;

for i := 0 to 255 do

begin

pal.palPalEntry[i].peRed := Random(255);

pal.palPalEntry[i].peGreen :=Random(255);

pal.palPalEntry[i].peBlue := Random(255);

end;

hpal := CreatePalette(pal^);

if hpal <> 0 then

Bitmap.Palette := hpal;

finally

FreeMem(pal);

end;

{$R+}

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

bitmap:=tbitmap.create;

bitmap.loadfromfile('c:program filesborlanddelphi 3imagessplash256colorfinance.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;

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.

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

Panodaki metnin diskteki bir dosyaya kaydedilmesi

unit Unit1;

interface

uses

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

Clipbrd, StdCtrls ;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function SaveClipboardTextDataToFile(

sFileTo : string ) : boolean;

var

ps1,

ps2 : PChar;

dwLen : DWord;

tf : TextFile;

hData : THandle;

begin

Result := False;

with Clipboard do

begin

try

Open;

if( HasFormat( CF_TEXT ) ) then

begin

hData :=

GetClipboardData( CF_TEXT );

ps1 := GlobalLock( hData );

dwLen := GlobalSize( hData );

ps2 := StrAlloc( 1 + dwLen );

StrLCopy( ps2, ps1, dwLen );

GlobalUnlock( hData );

AssignFile( tf, sFileTo );

ReWrite( tf );

Write( tf, ps2 );

CloseFile( tf );

StrDispose( ps2 );

Result := True;

end;

finally

Close;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

SaveClipboardTextDataToFile('c:silclip.asc');

end;

end.

4. Form ve Pencere işlemleri

Bu bölümde, Delphi uygulamaları içerisinde gerekebilecek form ve pencere işlemleri ile ilgili Püf noktaları ve kod örnekleri yer almaktadır.

Masa üstündeki ikonların saklanması

Aşağıdaki program çalıştırıldığında, görev çubuğu üzerindeki uyarı bölümünde bir ikon olarak görünür. Bu ikon üzerinde tıklandığında desktop üzerindeki ikonlar saklanır, bir kez daha basıldığında ise geri gelir.

program DeskPop;

uses

Windows, Messages, ShellAPI, sysutils;

{$R *.RES}

const

AppName = 'DeskTop Sakla';

var

x: integer;

tid: TNotifyIconData;

WndClass: array[0..50] of char;

procedure Panic (szMessage: PChar);

begin

if szMessage <> Nil then

MessageBox (0, szMessage, AppName, mb_ok);

Halt (0);

end;

procedure HandleCommand (Wnd: hWnd; Cmd: Word);

begin

case Cmd of

Ord ('A'): MessageBox (0, 'Merhaba', AppName, mb_ok);

Ord ('E'): PostMessage (Wnd, wm_Close, 0, 0);

end;

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;

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;

begin

WinMain;

end.

Bütün açık pencerelerin listelenmesi

Sistemde açık olan bütün pencerelerin listelenmesi için, EnumWindows fonksiyonu kullanılır.

function EnumWindowsProc(Wnd : HWnd;Form : TForm1) : Boolean; Export; {$ifdef Win32} StdCall; {$endif}

var

Buffer : Array[0..99] of char;

begin

GetWindowText(Wnd,Buffer,100);

if StrLen(Buffer) <> 0 then

Form.ListBox1.Items.Add(StrPas(Buffer));

Result := True;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

EnumWindows(@EnumWindowsProc,LongInt(Self));

end;

Farklı bir pencere

Standart Windows pencereleri, dikdörtgen veya kare şeklindedir. Değişik şekilli bir pencere yaratmak için;

var

hR : THandle;

begin

hR := CreateEllipticRgn(0,0,100,200);

SetWindowRgn(Handle,hR,True);

end;

Farklı pencereye bir başka örnek;

unit Unit1;

interface

uses

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

ExtCtrls, Buttons;

type

TForm1 = class(TForm)

SpeedButton1: TSpeedButton;

Image1: TImage;

procedure FormCreate(Sender: TObject);

procedure SpeedButton1Click(Sender: TObject);

private

{ Private declarations }

procedure CreateParams(var Params: TCreateParams); override;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

procedure TForm1.CreateParams(var Params: TCreateParams);

begin

inherited createparams(params);

params.style:=params.style or ws_popup xor ws_dlgframe;

end;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

var

formrgn:hrgn;

begin

form1.brush.style:=bsclear;

GetWindowRgn(form1.Handle, formRgn);

DeleteObject(formRgn);

formrgn:=

CreateroundRectRgn(0,

0,form1.width,form1.height,form1.width,form1.height);

SetWindowRgn(form1.Handle, formrgn, TRUE);

end;

procedure TForm1.SpeedButton1Click(Sender: TObject);

begin

form1.close;

end;

end.

Üzerine bırakılan dosyalara duyarlı form

unit dragfile;

interface

uses

Windows, Messages, SysUtils, Classes,

Graphics, Controls, Forms, Dialogs;

type

TForm2 = class(TForm)

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

procedure AcceptFiles( var msg : TMessage );

message WM_DROPFILES;

end;

var

Form2: TForm2;

implementation

uses

ShellAPI;

{$R *.DFM}

procedure TForm2.AcceptFiles( var msg : TMessage );

const

cnMaxFileNameLen = 255;

var

nCount : integer;

acFileName : array [0..cnMaxFileNameLen] of char;

begin

nCount := DragQueryFile( msg.WParam,

$FFFFFFFF,

acFileName,

cnMaxFileNameLen );

for i := 0 to nCount-1 do

begin

DragQueryFile( msg.WParam, i,

acFileName, cnMaxFileNameLen );

MessageBox( Handle, acFileName, '', MB_OK );

end;

DragFinish( msg.WParam );

end;

procedure TForm2.FormCreate(Sender: TObject);

begin

DragAcceptFiles( Handle, True );

end;

end.

Form başlığının saklanması

procedure TForm1.Createparams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

with Params do

Style := (Style or WS_POPUP) and (not WS_DLGFRAME);

end;

Standart dışı formlar

Windows'un standart formlarından sıkılanlar için, farklı bir form.

unit Unit1;

interface

uses

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

ExtCtrls, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Panel1: TPanel;

Panel2: TPanel;

Panel3: TPanel;

Panel4: TPanel;

Panel5: TPanel;

procedure FormResize(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormResize(Sender: TObject);

var

WindowRgn, HoleRgn : HRgn;

begin

WindowRgn := 0;

GetWindowRgn(Handle, WindowRgn);

DeleteObject(WindowRgn);

WindowRgn :=

CreateRectRgn(0,0,Width,Height);

HoleRgn :=

CreateRectRgn(Panel3.Width + 6,

Panel1.Height + 25,

Width - (Panel4.Width + 6),

Height - (Panel2.Height + 6));

CombineRgn(WindowRgn, WindowRgn,

HoleRgn, RGN_DIFF);

SetWindowRgn(Handle, WindowRgn, TRUE);

DeleteObject(HoleRgn);

end;

end.

object Form1: TForm1

Left = 216

Top = 178

AutoScroll = False

Caption = 'Form1'

ClientHeight = 453

ClientWidth = 688

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OnResize = FormResize

PixelsPerInch = 96

TextHeight = 13

object Button1: TButton

Left = 512

Top = 352

Width = 75

Height = 25

Caption = 'Button1'

TabOrder = 0

end

object Panel1: TPanel

Left = 0

Top = 0

Width = 688

Height = 5

Align = alTop

BevelOuter = bvNone

Color = clRed

TabOrder = 1

end

object Panel2: TPanel

Left = 0

Top = 443

Width = 688

Height = 10

Align = alBottom

BevelOuter = bvNone

Color = clRed

TabOrder = 2

end

object Panel3: TPanel

Left = 0

Top = 5

Width = 10

Height = 438

Align = alLeft

BevelOuter = bvNone

Color = clRed

TabOrder = 3

end

object Panel4: TPanel

Left = 678

Top = 5

Width = 10

Height = 438

Align = alRight

BevelOuter = bvNone

Color = clRed

TabOrder = 4

end

object Panel5: TPanel

Left = 10

Top = 5

Width = 668

Height = 438

Align = alClient

BevelOuter = bvLowered

Caption = 'Panel5'

TabOrder = 5

end

Form pozüsyonu

Unit1.pas

unit Unit1;

interface

uses

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

StdCtrls;

type

TForm1 = class(TForm)

private

{ Private declarations }

public

{ Public declarations }

Procedure WMMove(Var Message : TWMMove); message WM_Move;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

Procedure TForm1.WMMove(Var Message : TWMMove);

begin

Caption := 'X = '+IntToStr(Message.XPos)+', Y = '+IntTOStr(Message.

YPos);

end;

end.

Ekran Çözünürlüğü

Tasarım ortamın gayet düzgün görünen bir formun başka bir bilgisayarda bozuk görünmesi oldukça can sıkıcıdır. Bu olayın sebebi faklı ekran çözünürlükleri ve yazı tipi ayarıdır. Bunu önlemek için uygulama içerisinde bazı kontroller yapmak gerekir.

Aşağıdaki kod örneğinde form ve üzerindeki kontrollerin sistemdeki ayarlara göre yeniden ölçeklenmesi gösterilmektedir.

implementation

const

{formlarımızın 800x600 ölçülerinde olmasını istiyorsak…}

ScreenWidth: LongInt = 800;

ScreenHeight: LongInt = 600;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

scaled := true;

if (screen.width <> ScreenWidth) then

begin

height:=longint(height)*longint(screen.height)DIV

ScreenHeight;

width := longint(width) * longint(screen.width) DIV ScreenWidth;

scaleBy(screen.width, ScreenWidth);

end;

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;

Form başlık alanı üzerinde saat gösterilmesi

Formun Caption özelliğine dokunmadan, başlık alanı üzerinde saat bilgisi gösterimi şu şekilde olur.

unit Unit1;

interface

uses

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

ExtCtrls;

type

TForm1 = class(TForm)

Timer1: TTimer;

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure Timer1Timer(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

dc:hdc;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

dc:=getwindowdc(handle);

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

releasedc(handle,dc);

end;

procedure TForm1.Timer1Timer(Sender: TObject);

var

thetime: array[0..80] of char;

begin

strpcopy(Thetime,timetostr(time));

canvas.font.color:=clred;

textout(dc,width div 2,5,thetime,strlen(thetime));

end;

end.

Form başlığının gizlenmesi

Form başlıkları, çalışma esnasında gizlenip tekrar gösterilebilir.

unit Unit1;

interface

uses

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

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

procedure sakla;

procedure goster;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure tform1.sakla;

var

save:longint;

begin

if borderstyle=bsnone then exit;

save:=getwindowlong(handle,gwl_style);

if (save and ws_caption)=ws_caption then

begin

case borderstyle of

bssingle,bssizeable: setwindowlong(handle,gwl_style,save and (not(ws_caption)) or ws_border);

bsdialog:setwindowlong(handle,gwl_style,save and (not(ws_caption)) or ds_modalframe or ws_dlgframe);

end;

height:=height-getsystemmetrics(sm_cycaption);

refresh;

end;

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;

procedure TForm1.Button1Click(Sender: TObject);

begin

sakla

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

goster

end;

end.

Formun başlık alanına buton yerleştirme

Kullandığınız formların başlık alanına buton ekleyip, bu butona bazı görevler yükleyebilirsiniz.

unit CapBtn;

interface

uses

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

type

TForm1 = class(TForm)

procedure FormResize(Sender: TObject);

private

CaptionBtn : TRect;

procedure DrawCaptButton;

procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;

procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;

procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;

procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;

procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

const

htCaptionBtn = htSizeLast + 1;

{$R *.DFM}

procedure TForm1.DrawCaptButton;

var

xFrame,

yFrame,

xSize,

ySize : Integer;

R : TRect;

begin

//Form eni ve boyu

xFrame := GetSystemMetrics(SM_CXFRAME);

yFrame := GetSystemMetrics(SM_CYFRAME);

//Başlık butonlarının eni ve boyu

xSize := GetSystemMetrics(SM_CXSIZE);

ySize := GetSystemMetrics(SM_CYSIZE);

//Yeni butonun yeri

CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,

yFrame + 2, xSize - 2, ySize - 4);

//Forma ait DC 'yi kullanarak,

//üzerine çizim yapılacak tuvali bul

Canvas.Handle := GetWindowDC(Self.Handle);

Canvas.Font.Name := 'Symbol';

Canvas.Font.Color := clBlue;

Canvas.Font.Style := [fsBold];

Canvas.Pen.Color := clYellow;

Canvas.Brush.Color := clBtnFace;

try

DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False);

R := Bounds(Width - xFrame - 4 * xSize + 2,

yFrame + 3, xSize - 6, ySize - 7);

with CaptionBtn do

Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');

finally

ReleaseDC(Self.Handle, Canvas.Handle);

Canvas.Handle := 0;

end;

procedure TForm1.WMNCPaint(var Msg : TWMNCPaint);

begin

inherited;

DrawCaptButton;

end;

procedure TForm1.WMNCActivate(var Msg : TWMNCActivate);

begin

inherited;

DrawCaptButton;

end;

procedure TForm1.WMSetText(var Msg : TWMSetText);

begin

inherited;

DrawCaptButton;

end;

procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest);

begin

inherited;

with Msg do

if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then

Result := htCaptionBtn;

end;

procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);

begin

inherited;

if (Msg.HitTest = htCaptionBtn) then

ShowMessage('Hoops... yeni butona bastın');

end;

procedure TForm1.FormResize(Sender: TObject);

begin

//Başlık çubuğunun yeniden çizilmesini sağla

Perform(WM_NCACTIVATE, Word(Active), 0);

end;

end.

Açılır-Kapanır form

İşyeri kepengine benzer bir şekilde açılıp kapanabilen bir form yaratmak için kullanılabilecek kod örneği aşağıdadır. Açılma ve kapanma komutu, bu örnekte başlık alanı üzerinde sağ fare tuşuna basılarak verilmektedir.

unit KepengForm;

interface

uses

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

ExtCtrls, StdCtrls, Printers, Buttons, ShellAPI;

type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

FOldHeight : Integer;

procedure WMNCRButtonDown(var Msg : TWMNCRButtonDown); message WM_NCRBUTTONDOWN;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

FOldHeight := ClientHeight;

end;

procedure TForm1.WMNCRButtonDown(var Msg : TWMNCRButtonDown);

var

I : Integer;

begin

if (Msg.HitTest = HTCAPTION) then

if (ClientHeight = 0) then

begin

I := 0;

while (I < FOldHeight) do begin

I := I + 40;

if (I > FOldHeight) then

I := FOldHeight;

ClientHeight := I;

Application.ProcessMessages;

end;

end

else

begin

FOldHeight := ClientHeight;

I := ClientHeight;

//kapanma efekti için, I değerini doğrudan "0" a eşitlemek //yerine kademeli olarak azaltabilirsiniz.

I := 0;

ClientHeight := I;

Application.ProcessMessages;

end;

end.

Pencerenin taşınması

Windows pencereleri, ekran üzerinde başlıklarından tutularak taşınırlar. Pencere alanından tutulareak da taşınabilmeleri için, WM_NCHITTEST mesajının yakalanıp, yordamının değiştirilmesi gerekir.

type

TForm1 = class(TForm)

public

procedure WMNCHitTest(var M: TWMNCHitTest); message WM_NCHitTest;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);

begin

inherited;

if M.Result = htClient then

M.Result := htCaption;

end;

5. Disk ve Dosya işlemleri

Sürücü listesi

procedure TForm1.Button2Click(Sender: TObject);

var drives : dword;

i : integer;

begin

drives := GetLogicalDrives;

for i := 0 to 25 do //ingilizce alfabede 25 harf var

if ( drives and ( 1 shl i )) > 0 then

Listbox1.Items.Add( Chr( i + 65 ));

end;

veya

procedure TForm1.Button1Click(Sender: TObject);

var buffer : array[0..500] of char;

temp : PChar;

typ : integer;

begin

GetLogicalDriveStrings( sizeof( buffer ), buffer );

temp := buffer;

while temp[0] <> #0 do

begin

typ := GetDriveType( temp );

with ListBox1.Items do

case typ of

DRIVE_REMOVABLE : Add( temp + ' removable' );

DRIVE_FIXED : Add( temp + ' Sabit Disk' );

DRIVE_REMOTE : Add( temp + ' Ağ üzerinde' );

DRIVE_CDROM : Add( temp + ' CD-ROM' );

DRIVE_RAMDISK : Add( temp + ' RAM-disk' );

else

Add( temp + ' Bilinmiyor' );

end;

temp := StrEnd( temp ) + 1;

end;

Disket Sürücüsünde disket takılı mı ?

{$I-}

ChDir('a:');

{$I+}

if IOResult <> 0 then

ShowMessage( 'a sürücüsünde Disket yok' );

Veya;

function DiskInDrive(const Drive: char): Boolean;

var

DrvNum: byte;

EMode: Word;

begin

result := false;

DrvNum := ord(Drive);

if DrvNum >= ord('a') then dec(DrvNum,$20);

EMode := SetErrorMode(SEM_FAILCRITICALERRORS);

try

if DiskSize(DrvNum-$40) <> -1 then result := true

else messagebeep(0);

finally

SetErrorMode(EMode);

end;

Çalışan uygulamanın bulunduğu dizin

procedure TForm1.Button1Click(Sender: TObject);

var

szFileName : array[0..99] of char;

szModuleName : array[0..19] of char;

iSize : integer;

begin

iSize := GetModuleFileName(GetModuleHandle(szModuleName),szFileName,

SizeOf(szFileName));

if iSize > 0 then

ShowMessage('Tam dizin : ' + StrPas(szFileName))

else

ShowMessage('Bulunamadı');

end;

Windows'un standart "BrowseFolder" Diyalog penceresinin kullanılması

unit Unit1;

interface

uses

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

StdCtrls,ShlObj,ActiveX;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

var BI:TBrowseInfo;

Buf:PChar;

Dir,Root:PItemIDList;

Alloc:IMalloc;

begin

SHGetMalloc(Alloc);

Buf:=Alloc.Alloc(Max_Path);

// Bu satır aranacak dizinleri sınırlar.

SHGetSpecialFolderLocation(Handle,CSIDL_PROGRAMS,Root);

with BI do

begin

hwndOwner:=Form1.Handle;

pidlRoot:=Root; // Eğer Nil olursa, bütün dizinler

// görüntülenir.

pszDisplayName:=Buf;

lpszTitle:=' İstediğiniz dizini seçiniz';

ulFlags:=0;

lpfn:=nil;

end;

try

Dir:=SHBrowseForFolder(BI);

if Dir<>Nil then

begin

SHGetPathFromIDList(Dir,Buf); // İstenen dizinin tam adı

ShowMessage(Buf);

Alloc.Free(Dir);

end;

finally

Alloc.Free(Root);

Alloc.Free(Buf);

end;

end.

Seçilebilecek, diğer özel Klasör tipleri

CSIDL_BITBUCKET Geri dönüşüm kutusu

CSIDL_CONTROLS Kontrol panel klasörleri

CSIDL_DESKTOP Masaüstü klasörleri

CSIDL_DESKTOPDIRECTORY Masaüstü nesnelerini barındıran klasör

CSIDL_DRIVES Bilgisayarım klasörü

CSIDL_FONTS Font klasörü

CSIDL_NETHOOD Ağ komşuluğu klasörü

CSIDL_NETWORK Yukarıdakinin bir başka versiyonu

CSIDL_PERSONAL Şahsi klasör

CSIDL_PRINTERS Yazıcılar klasörü

CSIDL_PROGRAMS Başlat menüsündeki programlar klasörü

CSIDL_RECENT Son kullanılan dökümanlar klasörü

CSIDL_SENDTO Gönder (SendTo) klasörü

CSIDL_STARTMENU Başlat menüsünün tümü

CSIDL_STARTUP Otomatik başlat klasörü

CSIDL_TEMPLATES Döküman şablonları

Bir dizindeki dosyaların ve alt dizinlerin tümünün silinmesi

procedure removeTree (DirName: string);

var

FileSearch: SearchRec;

begin

chDir (DirName);

FindFirst ('*.*', Directory, FileSearch);

while (DosError = 0) do begin

if (FileSearch.name <> '.') AND (FileSearch.name <> '..') AND

( (FileSearch.attr AND Directory) <> 0)

then begin

if DirName[length(DirName)] = '' then

removeTree (DirName+FileSearch.Name)

else

removeTree (DirName+''+FileSearch.Name);

ChDir (DirName);

end;

FindNext (FileSearch)

end;

FindFirst ('*.*', AnyFile, FileSearch);

while (DosError = 0) do begin

if (FileSearch.name <> '.') AND (FileSearch.name <> '..') then

Remove (workdir);

end;

FindNext (FileSearch)

end;

rmDir (DirName)

end;

Dosya kopyalama

Aşağıdaki kodu içeren unitin Uses listesine "LZExpand"eklenmelidir.

var

SourceHandle, DestHandle: Integer;

SName,DName: String;

begin

SourceHandle := FileOpen(SName,0);

DestHandle := FileCreate(DName);

LZCopy(SourceHandle,DestHandle);

FileClose(SourceHandle);

FileClose(DestHandle);

End;

Başka bir kopyalama yöntemi;

function FileCopy(source,dest: String): Boolean;

var

fSrc,fDst,len: Integer;

size: Longint;

buffer: packed array [0..2047] of Byte;

begin

Result := False;

if source <> dest then begin

fSrc := FileOpen(source,fmOpenRead);

if fSrc >= 0 then begin

size := FileSeek(fSrc,0,2);

FileSeek(fSrc,0,0);

fDst := FileCreate(dest);

if fDst >= 0 then begin

while size > 0 do begin

len := FileRead(fSrc,buffer,sizeof(buffer));

FileWrite(fDst,buffer,len);

size := size - len;

end;

FileSetDate(fDst,FileGetDate(fSrc));

FileClose(fDst);

FileSetAttr(dest,FileGetAttr(source));

Result := True;

end;

FileClose(fSrc);

end;

İkili dosyadan okuma

var

f: File;

c: Char;

begin

AssignFile(f, 'Dosyaadi.bin');

Reset(f, 1);

BlockRead(f, c, sizeof(c));

CloseFile(f);

end;

Yukarıdaki kod her seferinde bir karakter okur. Disk erişimi yavaş bir işlemdir. Bu nedenle bir mecburiyet yoksa, her seferinde 1 karakter yerine daha fazlası okunmalıdır.

Bir dosyanın salt okunur olarak açılması

Assignfile satırından sonra dosya açma modu belirtilmelidir.

AssignFile(F, FileName);

FileMode := 0; ( Salt okunur }

Reset(F);

CloseFile(F);

Satır sonu karakterinin Ascii kodu nedir?

Control-Z, veya 26 numaralı ASCII karakteri

Disk seri numarası ve etiketinin okunması

unit diskinfo;

interface

uses

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

StdCtrls;

type

diskinfostructure=record

DiskEtiketi:string;

DiskSeriNo :string;

end;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

f:system.text;

blg:diskinfostructure;

implementation

{$R *.DFM}

Function WinExecute32(

FileName : String;

Visibility : integer):integer;

var

zAppName:array[0..512] of char;

zCurDir:array[0..255] of char;

WorkDir:String;

StartupInfo:TStartupInfo;

ProcessInfo:TProcessInformation;

begin

StrPCopy(zAppName,FileName);

GetDir(0,WorkDir);

StrPCopy(zCurDir,WorkDir);

FillChar(StartupInfo,Sizeof(StartupInfo),#0);

StartupInfo.cb := Sizeof(StartupInfo);

StartupInfo.dwFlags := STARTF_USESHOWWINDOW;

StartupInfo.wShowWindow := Visibility;

if not CreateProcess(nil,

zAppName,

nil,

false,

CREATE_NEW_CONSOLE or

NORMAL_PRIORITY_CLASS,

nil,

StartupInfo,

ProcessInfo) then Result := -1

else

begin

WaitforSingleObject(ProcessInfo.hProcess,INFINITE);

GetExitCodeProcess(ProcessInfo.hProcess,Result);

end;

function disk(dsk:char;var bilgi:diskinfostructure):boolean;

var

row:array[1..50] of string;

c,i:integer;

vollabel,serial:string;

begin

assignfile(f,'c:dir.bat');

rewrite(f);

writeln(f,'dir '+dsk+':*.zzzz> c:dir.txt');

closefile(f);

winexecute32('c:dir.bat',0);

assignfile(f,'c:dir.txt');

reset(f);

i:=1;

while not eof(f) do

begin

readln(f,row[i]);

inc(i,1);

end;

closefile(f);

if pos('is',row[2])>0 then

bilgi.DiskEtiketi:=copy(row[2],pos('is',row[2])+2,11)

else bilgi.DiskEtiketi:='Disk etiketi yok';

bilgi.DiskSeriNo:= copy(row[3],pos('is',row[3])+2,15);

deletefile('c:dir.bat');

deletefile('c:dir.txt');

result:=true;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

disk('c',blg);

showmessage(blg.DiskEtiketi);

showmessage(blg.DiskSeriNo);

end;

end.

Disk seri numarasına erişimin başka bir yolu..

unit diskvol;

interface

uses

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

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function GetDiskVolSerialID(

cDriveName : char ) : DWord;

var

dwTemp1,

dwTemp2 : DWord;

begin

GetVolumeInformation(

PChar( cDriveName + ':' ),

Nil,

@Result,

dwTemp2,

Nil,

);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

showmessage(inttostr(GetDiskVolSerialID('C')))

end;

end.

Disk bilgilerini elde etmenin bir diğer yolu ise;

type

VolInf=record

Etiket:string;

serino:string;

tip:string;

disk_Tip:string;

bos_yer:string;

Top_Yer:string;

end;

function VolInfo(var diskinfos:volinf;disk:char):boolean;

type

TDrvType = (dtNotDetermined, dtNonExistent, dtRemoveable,

dtFixed, dtRemote, dtCDROM, dtRamDrive);

var

//Disk bigisi kayıtı

nVNameSer : PDWORD;

drv : String;

pVolName : PChar;

FSSysFlags,

maxCmpLen : DWord;

I : Integer;

pFSBuf : PChar;

dType : TDrvType;

SectPerCls,

BytesPerCls,

FreeCls,

TotCls : DWord;

begin

//Değişkenleri sıfırla

drv := disk + ':';

GetMem(pVolName, MAX_PATH);

GetMem(pFSBuf, MAX_PATH);

GetMem(nVNameSer, MAX_PATH);

//Disk Volume bilgisini al

GetVolumeInformation(PChar(drv), pVolName, MAX_PATH, nVNameSer, maxCmpLen, FSSysFlags, pFSBuf, MAX_PATH);

//Sistem uzun dosya isimlerini destekliyormu?

if (maxCmpLen > 8.3) then

diskinfos.Etiket:= StrPas(pVolName);

diskinfos.serino:=IntToStr(nVNameSer^);

diskinfos.tip:=StrPas(pFSBuf);//dosyasistemi

//Sürücü tipi bilgilerini al

dType := TDrvType(GetDriveType(PChar(drv)));

case dType of

dtNotDetermined : diskinfos.disk_Tip := 'Tespit edilemedi';

dtNonExistent : diskinfos.disk_Tip := 'Mevcut değil';

dtRemoveable : diskinfos.disk_Tip := 'Portatif disk (Floppy)';

dtFixed : diskinfos.disk_Tip := 'Sabit disk';

dtRemote : diskinfos.disk_Tip := 'Uzak veya ağ sürücüsü';

dtCDROM : diskinfos.disk_Tip := 'CD-ROM sürücü';

dtRamDrive : diskinfos.disk_Tip := 'RAM sürücü';

end;

//Diskteki toplam ve boş alan bilgisini al (MB)

GetDiskFreeSpace(PChar(drv), SectPerCls, BytesPerCls, FreeCls, TotCls);

diskinfos.bos_yer:=FormatFloat('0.00', (SectPerCls * BytesPerCls * FreeCls)/1000000) + ' MB';

diskinfos.Top_Yer:= FormatFloat('0.00', (SectPerCls * BytesPerCls * TotCls)/1000000) + ' MB';

//Hafızayı temizle

FreeMem(pVolName, MAX_PATH);

FreeMem(pFSBuf, MAX_PATH);

FreeMem(nVNameSer, MAX_PATH);

end;

Bir dosyanın tarih ve saat bilgisinin alınması

procedure TForm1.Button1Click(Sender: TObject);

var

TheFileDate: string;

Fhandle: integer;

begin

FHandle := FileOpen('C:COMMAND.COM', 0);

Try

TheFileDate :=

DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));

finally

FileClose(FHandle);

end;

SHOWMESSAGE(THEFILEDATE);

end;

Bir klasörün özelliğinin değiştirilmesi

Aşağıdaki kod örneğinde, bir klasörün "Hidden" özelliği değiştirilmektedir.

Function DirectoryHide(Const FileString : String): Boolean;

Var

Attributes : Integer;

Begin

Result := False;

Try

If Not DirectoryExists(FileString) Then Exit;

Attributes := faDirectory + faHidden + faSysFile;

FileSetAttr(FileString,Attributes);

Result := True;

Except

End;

---

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;

Dosyanın sürüklenip bırakılması

Fare ile sürüklenerek, aşağıdaki unite bağlı form üzerine dosya bırakıldığında, bırakılan dosyanın dizini ve adı tespit edilmektedir.

unit dragfile;

interface

uses

Windows, Messages, SysUtils, Classes,

Graphics, Controls, Forms, Dialogs;

type

TForm2 = class(TForm)

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

procedure AcceptFiles( var msg : TMessage );

message WM_DROPFILES;

end;

var

Form2: TForm2;

implementation

uses

ShellAPI;

{$R *.DFM}

procedure TForm2.AcceptFiles( var msg : TMessage );

const

cnMaxFileNameLen = 255;

var

nCount : integer;

acFileName : array [0..cnMaxFileNameLen] of char;

begin

nCount := DragQueryFile( msg.WParam,

$FFFFFFFF,

acFileName,

cnMaxFileNameLen );

for i := 0 to nCount-1 do

begin

DragQueryFile( msg.WParam, i,

acFileName, cnMaxFileNameLen );

MessageBox( Handle, acFileName, '', MB_OK );

end;

DragFinish( msg.WParam );

end;

procedure TForm2.FormCreate(Sender: TObject);

begin

DragAcceptFiles( Handle, True );

end;

end.

Windows geçici klasörünün bulunması

Windows 95 ve NT işletim sistemlerinde, geçici dosyalar için kullanılan, genellikle "TEMP" isimli bir klasör vardır. Fakat bazen kullanıcılar bu dizinin adını veya yerini değiştirirler. Aşağıdaki fonksiyon, geçici dizini tespit eder.

function GetTempDirectory: String;

var

TempDir: array[0..255] of Char;

begin

GetTempPath(255, @TempDir);

Result := StrPas(TempDir);

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

showmessage(gettempdirectory);

end;

Windows sistem dizininin bulunması

Var

SysDir: PChar;

Size: Word;

SysDirInString : String[144];

Begin

SysDir := '';

GetSystemDirectory(SysDir, Size);

SysDirInString := StrPas(SysDir);

Canvas.TextOut(10, 10, SysDirInString);

end;

Dosya yaratılma tarihi

Bu fonksiyon, dosyanın yaratıldığı tarihi döndürür.

Function File_GetCreationDate(FileName : String): TDateTime;

var

SearchRec : TSearchRec;

DT : TFileTime;

ST : TSystemTime;

begin

Result := 0;

If Not FileExists(FileName) Then Exit;

Try

SysUtils.FindFirst(FileName, faAnyFile, SearchRec);

Try

FileTimeToLocalFileTime(SearchRec.FindData.ftCreationTime,DT);

FileTimeToSystemTime(DT, ST);

Result := SystemTimeToDateTime(ST);

Finally

SysUtils.FindClose(SearchRec);

End;

Except

Result := 0;

End;

end;

Dosyanın son kullanıldığı tarih

Bu fonksiyon, dosyanın, son olarak kullanıldığı tarihi döndürür.

Function File_GetLastAccessDate(FileName : String): TDateTime;

var

SearchRec : TSearchRec;

DT : TFileTime;

ST : TSystemTime;

begin

Result := 0;

If Not FileExists(FileName) Then Exit;

Try

SysUtils.FindFirst(FileName, faAnyFile, SearchRec);

Try

FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT);

FileTimeToSystemTime(DT, ST);

Result := SystemTimeToDateTime(ST);

Finally

SysUtils.FindClose(SearchRec);

End;

Except

Result := 0;

End;

end;

Dosyanın son değiştirildiği tarih

Bu fonksiyon, FileName parametresi ile gönderilen dosyanın, son olarak değiştirildiği tarihi bulmaya yarar.

Function File_GetLastModifiedDate(FileName : String): TDateTime;

var

SearchRec : TSearchRec;

DT : TFileTime;

ST : TSystemTime;

begin

Result := 0;

If Not FileExists(FileName) Then Exit;

Try

SysUtils.FindFirst(FileName, faAnyFile, SearchRec);

Try

FileTimeToLocalFileTime(SearchRec.FindData.ftLastWriteTime,DT);

FileTimeToSystemTime(DT, ST);

Result := SystemTimeToDateTime(ST);

Finally

SysUtils.FindClose(SearchRec);

End;

Except

Result := 0;

End;

end;

Dizin boşmu?

DirName parametresi ile gönderilen dizinin boş olup olmadığını kontrol etmeye yarayan bir fonksiyon.

Function IsDirEmpty(DirName: String): Boolean;

Begin

If IsDir(DirName) Then

Begin

If IsFile(DirName+'*.*') Then

Begin

Result := False;

End

Else

Begin

Result := True;

End;

End

Else

Begin

Result := False;

End;

Dosya uzantısı hangi programla bağlantılı?

Bir dosyanın uzantısına bakarak, hangi program tarafından çalıştırılacağının bulunması için aşağıdaki kod örneği kullanılabilir.

unit Unit1;

interface

uses

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

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

const

BufferSize = {$IFDEF Win32} 540 {$ELSE} 80 {$ENDIF};

var

Buffer : PChar;

StringPosition : PChar;

ReturnedData: Longint;

begin

Buffer := StrAlloc(BufferSize);

try

{ get the first entry, don't bother about the version !}

ReturnedData := BufferSize;

StrPCopy(Buffer, '.pas');

RegQueryValue(hKey_Classes_Root, Buffer, Buffer, ReturnedData);

if StrLen(Buffer) > 0 then

begin

showmessage(strpas(buffer));

end;

except

showmessage('bulunamadı');

end;

end.

Geri dönüşüm kutusuna gönder.

Bir dosyayı, geri dönüşüm kutusuna göndererek silmek için ;

unit Unit1;

interface

uses

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

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

uses

ShellApi;

function DF(sFileName : string ) : boolean;

var

fos : TSHFileOpStruct;

begin

FillChar( fos, SizeOf( fos ), 0 );

with fos do

begin

Wnd := application.handle;

wFunc := FO_DELETE;

pFrom := PChar( sFileName );

fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;

end;

Result := ( 0 = ShFileOperation( fos ) );

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

df('c:&quotWP.txt');

end;

end.