Programlama yapalım ve Öğrenelim.

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.

6. Genel

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

Karakter dizisi karşılaştırma

unit matchstring;

interface

uses

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

StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

CheckBox1: TCheckBox;

Edit1: TEdit;

Edit2: TEdit;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

function MatchStrings(source, pattern: String): Boolean;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function tform1.MatchStrings(source, pattern: String): Boolean;

var

pSource: Array [0..255] of Char;

pPattern: Array [0..255] of Char;

function MatchPattern(element, pattern: PChar): Boolean;

function IsPatternWild(pattern: PChar): Boolean;

var

t: Integer;

begin

Result := StrScan(pattern,'*') <> nil;

if not Result then Result := StrScan(pattern,'?') <> nil;

end;

begin

if 0 = StrComp(pattern,'*') then

Result := True

else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then

Result := False

else if element^ = Chr(0) then

Result := True

else begin

case pattern^ of

'*': if MatchPattern(element,@pattern[1]) then

Result := True

else

Result := MatchPattern(@element[1],pattern);

'?': Result := MatchPattern(@element[1],@pattern[1]);

else

if element^ = pattern^ then

Result := MatchPattern(@element[1],@pattern[1])

else

Result := False;

end;

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.