Formun başlık alanına buton yerleştirme
Kullandığınız formların başlık alanına buton ekleyip, bu butona bazı görevler yükleyebilirsiniz.
unit CapBtn;
interface
uses
Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TForm1 = class(TForm)
procedure FormResize(Sender: TObject);
private
CaptionBtn : TRect;
procedure DrawCaptButton;
procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;
procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;
procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;
procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;
procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
const
htCaptionBtn = htSizeLast + 1;
{$R *.DFM}
procedure TForm1.DrawCaptButton;
var
xFrame,
yFrame,
xSize,
ySize : Integer;
R : TRect;
begin
//Form eni ve boyu
xFrame := GetSystemMetrics(SM_CXFRAME);
yFrame := GetSystemMetrics(SM_CYFRAME);
//Başlık butonlarının eni ve boyu
xSize := GetSystemMetrics(SM_CXSIZE);
ySize := GetSystemMetrics(SM_CYSIZE);
//Yeni butonun yeri
CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,
yFrame + 2, xSize - 2, ySize - 4);
//Forma ait DC 'yi kullanarak,
//üzerine çizim yapılacak tuvali bul
Canvas.Handle := GetWindowDC(Self.Handle);
Canvas.Font.Name := 'Symbol';
Canvas.Font.Color := clBlue;
Canvas.Font.Style := [fsBold];
Canvas.Pen.Color := clYellow;
Canvas.Brush.Color := clBtnFace;
try
DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False);
R := Bounds(Width - xFrame - 4 * xSize + 2,
yFrame + 3, xSize - 6, ySize - 7);
with CaptionBtn do
Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');
finally
ReleaseDC(Self.Handle, Canvas.Handle);
Canvas.Handle := 0;
end;
end;
procedure TForm1.WMNCPaint(var Msg : TWMNCPaint);
begin
inherited;
DrawCaptButton;
end;
procedure TForm1.WMNCActivate(var Msg : TWMNCActivate);
begin
inherited;
DrawCaptButton;
end;
procedure TForm1.WMSetText(var Msg : TWMSetText);
begin
inherited;
DrawCaptButton;
end;
procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest);
begin
inherited;
with Msg do
if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then
Result := htCaptionBtn;
end;
procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);
begin
inherited;
if (Msg.HitTest = htCaptionBtn) then
ShowMessage('Hoops... yeni butona bastın');
end;
procedure TForm1.FormResize(Sender: TObject);
begin
//Başlık çubuğunun yeniden çizilmesini sağla
Perform(WM_NCACTIVATE, Word(Active), 0);
end;
end.
Açılır-Kapanır form
İşyeri kepengine benzer bir şekilde açılıp kapanabilen bir form yaratmak için kullanılabilecek kod örneği aşağıdadır. Açılma ve kapanma komutu, bu örnekte başlık alanı üzerinde sağ fare tuşuna basılarak verilmektedir.
unit KepengForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, Printers, Buttons, ShellAPI;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
FOldHeight : Integer;
procedure WMNCRButtonDown(var Msg : TWMNCRButtonDown); message WM_NCRBUTTONDOWN;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
FOldHeight := ClientHeight;
end;
procedure TForm1.WMNCRButtonDown(var Msg : TWMNCRButtonDown);
var
I : Integer;
begin
if (Msg.HitTest = HTCAPTION) then
if (ClientHeight = 0) then
begin
I := 0;
while (I < FOldHeight) do begin
I := I + 40;
if (I > FOldHeight) then
I := FOldHeight;
ClientHeight := I;
Application.ProcessMessages;
end;
end
else
begin
FOldHeight := ClientHeight;
I := ClientHeight;
//kapanma efekti için, I değerini doğrudan "0" a eşitlemek //yerine kademeli olarak azaltabilirsiniz.
I := 0;
ClientHeight := I;
Application.ProcessMessages;
end;
end;
end.
Pencerenin taşınması
Windows pencereleri, ekran üzerinde başlıklarından tutularak taşınırlar. Pencere alanından tutulareak da taşınabilmeleri için, WM_NCHITTEST mesajının yakalanıp, yordamının değiştirilmesi gerekir.
type
TForm1 = class(TForm)
public
procedure WMNCHitTest(var M: TWMNCHitTest); message WM_NCHitTest;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
inherited;
if M.Result = htClient then
M.Result := htCaption;
end;
5. Disk ve Dosya işlemleri
Sürücü listesi
procedure TForm1.Button2Click(Sender: TObject);
var drives : dword;
i : integer;
begin
drives := GetLogicalDrives;
for i := 0 to 25 do //ingilizce alfabede 25 harf var
if ( drives and ( 1 shl i )) > 0 then
Listbox1.Items.Add( Chr( i + 65 ));
end;
veya
procedure TForm1.Button1Click(Sender: TObject);
var buffer : array[0..500] of char;
temp : PChar;
typ : integer;
begin
GetLogicalDriveStrings( sizeof( buffer ), buffer );
temp := buffer;
while temp[0] <> #0 do
begin
typ := GetDriveType( temp );
with ListBox1.Items do
case typ of
DRIVE_REMOVABLE : Add( temp + ' removable' );
DRIVE_FIXED : Add( temp + ' Sabit Disk' );
DRIVE_REMOTE : Add( temp + ' Ağ üzerinde' );
DRIVE_CDROM : Add( temp + ' CD-ROM' );
DRIVE_RAMDISK : Add( temp + ' RAM-disk' );
else
Add( temp + ' Bilinmiyor' );
end;
temp := StrEnd( temp ) + 1;
end;
end;
Disket Sürücüsünde disket takılı mı ?
{$I-}
ChDir('a:');
{$I+}
if IOResult <> 0 then
ShowMessage( 'a sürücüsünde Disket yok' );
Veya;
function DiskInDrive(const Drive: char): Boolean;
var
DrvNum: byte;
EMode: Word;
begin
result := false;
DrvNum := ord(Drive);
if DrvNum >= ord('a') then dec(DrvNum,$20);
EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
if DiskSize(DrvNum-$40) <> -1 then result := true
else messagebeep(0);
finally
SetErrorMode(EMode);
end;
end;
Çalışan uygulamanın bulunduğu dizin
procedure TForm1.Button1Click(Sender: TObject);
var
szFileName : array[0..99] of char;
szModuleName : array[0..19] of char;
iSize : integer;
begin
iSize := GetModuleFileName(GetModuleHandle(szModuleName),szFileName,
SizeOf(szFileName));
if iSize > 0 then
ShowMessage('Tam dizin : ' + StrPas(szFileName))
else
ShowMessage('Bulunamadı');
end;
Windows'un standart "BrowseFolder" Diyalog penceresinin kullanılması
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,ShlObj,ActiveX;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var BI:TBrowseInfo;
Buf:PChar;
Dir,Root:PItemIDList;
Alloc:IMalloc;
begin
SHGetMalloc(Alloc);
Buf:=Alloc.Alloc(Max_Path);
// Bu satır aranacak dizinleri sınırlar.
SHGetSpecialFolderLocation(Handle,CSIDL_PROGRAMS,Root);
with BI do
begin
hwndOwner:=Form1.Handle;
pidlRoot:=Root; // Eğer Nil olursa, bütün dizinler
// görüntülenir.
pszDisplayName:=Buf;
lpszTitle:=' İstediğiniz dizini seçiniz';
ulFlags:=0;
lpfn:=nil;
end;
try
Dir:=SHBrowseForFolder(BI);
if Dir<>Nil then
begin
SHGetPathFromIDList(Dir,Buf); // İstenen dizinin tam adı
ShowMessage(Buf);
Alloc.Free(Dir);
end;
finally
Alloc.Free(Root);
Alloc.Free(Buf);
end;
end;
end.
Seçilebilecek, diğer özel Klasör tipleri
CSIDL_BITBUCKET Geri dönüşüm kutusu
CSIDL_CONTROLS Kontrol panel klasörleri
CSIDL_DESKTOP Masaüstü klasörleri
CSIDL_DESKTOPDIRECTORY Masaüstü nesnelerini barındıran klasör
CSIDL_DRIVES Bilgisayarım klasörü
CSIDL_FONTS Font klasörü
CSIDL_NETHOOD Ağ komşuluğu klasörü
CSIDL_NETWORK Yukarıdakinin bir başka versiyonu
CSIDL_PERSONAL Şahsi klasör
CSIDL_PRINTERS Yazıcılar klasörü
CSIDL_PROGRAMS Başlat menüsündeki programlar klasörü
CSIDL_RECENT Son kullanılan dökümanlar klasörü
CSIDL_SENDTO Gönder (SendTo) klasörü
CSIDL_STARTMENU Başlat menüsünün tümü
CSIDL_STARTUP Otomatik başlat klasörü
CSIDL_TEMPLATES Döküman şablonları
Bir dizindeki dosyaların ve alt dizinlerin tümünün silinmesi
procedure removeTree (DirName: string);
var
FileSearch: SearchRec;
begin
chDir (DirName);
FindFirst ('*.*', Directory, FileSearch);
while (DosError = 0) do begin
if (FileSearch.name <> '.') AND (FileSearch.name <> '..') AND
( (FileSearch.attr AND Directory) <> 0)
then begin
if DirName[length(DirName)] = '' then
removeTree (DirName+FileSearch.Name)
else
removeTree (DirName+''+FileSearch.Name);
ChDir (DirName);
end;
FindNext (FileSearch)
end;
FindFirst ('*.*', AnyFile, FileSearch);
while (DosError = 0) do begin
if (FileSearch.name <> '.') AND (FileSearch.name <> '..') then
Remove (workdir);
end;
FindNext (FileSearch)
end;
rmDir (DirName)
end;
Dosya kopyalama
Aşağıdaki kodu içeren unitin Uses listesine "LZExpand"eklenmelidir.
var
SourceHandle, DestHandle: Integer;
SName,DName: String;
begin
SourceHandle := FileOpen(SName,0);
DestHandle := FileCreate(DName);
LZCopy(SourceHandle,DestHandle);
FileClose(SourceHandle);
FileClose(DestHandle);
End;
Başka bir kopyalama yöntemi;
function FileCopy(source,dest: String): Boolean;
var
fSrc,fDst,len: Integer;
size: Longint;
buffer: packed array [0..2047] of Byte;
begin
Result := False;
if source <> dest then begin
fSrc := FileOpen(source,fmOpenRead);
if fSrc >= 0 then begin
size := FileSeek(fSrc,0,2);
FileSeek(fSrc,0,0);
fDst := FileCreate(dest);
if fDst >= 0 then begin
while size > 0 do begin
len := FileRead(fSrc,buffer,sizeof(buffer));
FileWrite(fDst,buffer,len);
size := size - len;
end;
FileSetDate(fDst,FileGetDate(fSrc));
FileClose(fDst);
FileSetAttr(dest,FileGetAttr(source));
Result := True;
end;
FileClose(fSrc);
end;
end;
end;
İkili dosyadan okuma
var
f: File;
c: Char;
begin
AssignFile(f, 'Dosyaadi.bin');
Reset(f, 1);
BlockRead(f, c, sizeof(c));
CloseFile(f);
end;
Yukarıdaki kod her seferinde bir karakter okur. Disk erişimi yavaş bir işlemdir. Bu nedenle bir mecburiyet yoksa, her seferinde 1 karakter yerine daha fazlası okunmalıdır.
Bir dosyanın salt okunur olarak açılması
Assignfile satırından sonra dosya açma modu belirtilmelidir.
AssignFile(F, FileName);
FileMode := 0; ( Salt okunur }
Reset(F);
CloseFile(F);
Satır sonu karakterinin Ascii kodu nedir?
Control-Z, veya 26 numaralı ASCII karakteri
Disk seri numarası ve etiketinin okunması
unit diskinfo;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
diskinfostructure=record
DiskEtiketi:string;
DiskSeriNo :string;
end;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
f:system.text;
blg:diskinfostructure;
implementation
{$R *.DFM}
Function WinExecute32(
FileName : String;
Visibility : integer):integer;
var
zAppName:array[0..512] of char;
zCurDir:array[0..255] of char;
WorkDir:String;
StartupInfo:TStartupInfo;
ProcessInfo:TProcessInformation;
begin
StrPCopy(zAppName,FileName);
GetDir(0,WorkDir);
StrPCopy(zCurDir,WorkDir);
FillChar(StartupInfo,Sizeof(StartupInfo),#0);
StartupInfo.cb := Sizeof(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not CreateProcess(nil,
zAppName,
nil,
nil,
false,
CREATE_NEW_CONSOLE or
NORMAL_PRIORITY_CLASS,
nil,
nil,
StartupInfo,
ProcessInfo) then Result := -1
else
begin
WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess,Result);
end;
end;
function disk(dsk:char;var bilgi:diskinfostructure):boolean;
var
row:array[1..50] of string;
c,i:integer;
vollabel,serial:string;
begin
assignfile(f,'c:dir.bat');
rewrite(f);
writeln(f,'dir '+dsk+':*.zzzz> c:dir.txt');
closefile(f);
winexecute32('c:dir.bat',0);
assignfile(f,'c:dir.txt');
reset(f);
i:=1;
while not eof(f) do
begin
readln(f,row[i]);
inc(i,1);
end;
closefile(f);
if pos('is',row[2])>0 then
bilgi.DiskEtiketi:=copy(row[2],pos('is',row[2])+2,11)
else bilgi.DiskEtiketi:='Disk etiketi yok';
bilgi.DiskSeriNo:= copy(row[3],pos('is',row[3])+2,15);
deletefile('c:dir.bat');
deletefile('c:dir.txt');
result:=true;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
disk('c',blg);
showmessage(blg.DiskEtiketi);
showmessage(blg.DiskSeriNo);
end;
end.
Disk seri numarasına erişimin başka bir yolu..
unit diskvol;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function GetDiskVolSerialID(
cDriveName : char ) : DWord;
var
dwTemp1,
dwTemp2 : DWord;
begin
GetVolumeInformation(
PChar( cDriveName + ':' ),
Nil,
0,
@Result,
dwTemp2,
dwTemp2,
Nil,
0
);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
showmessage(inttostr(GetDiskVolSerialID('C')))
end;
end.
Disk bilgilerini elde etmenin bir diğer yolu ise;
type
VolInf=record
Etiket:string;
serino:string;
tip:string;
disk_Tip:string;
bos_yer:string;
Top_Yer:string;
end;
function VolInfo(var diskinfos:volinf;disk:char):boolean;
type
TDrvType = (dtNotDetermined, dtNonExistent, dtRemoveable,
dtFixed, dtRemote, dtCDROM, dtRamDrive);
var
//Disk bigisi kayıtı
nVNameSer : PDWORD;
drv : String;
pVolName : PChar;
FSSysFlags,
maxCmpLen : DWord;
I : Integer;
pFSBuf : PChar;
dType : TDrvType;
SectPerCls,
BytesPerCls,
FreeCls,
TotCls : DWord;
begin
//Değişkenleri sıfırla
drv := disk + ':';
GetMem(pVolName, MAX_PATH);
GetMem(pFSBuf, MAX_PATH);
GetMem(nVNameSer, MAX_PATH);
//Disk Volume bilgisini al
GetVolumeInformation(PChar(drv), pVolName, MAX_PATH, nVNameSer, maxCmpLen, FSSysFlags, pFSBuf, MAX_PATH);
//Sistem uzun dosya isimlerini destekliyormu?
if (maxCmpLen > 8.3) then
diskinfos.Etiket:= StrPas(pVolName);
diskinfos.serino:=IntToStr(nVNameSer^);
diskinfos.tip:=StrPas(pFSBuf);//dosyasistemi
//Sürücü tipi bilgilerini al
dType := TDrvType(GetDriveType(PChar(drv)));
case dType of
dtNotDetermined : diskinfos.disk_Tip := 'Tespit edilemedi';
dtNonExistent : diskinfos.disk_Tip := 'Mevcut değil';
dtRemoveable : diskinfos.disk_Tip := 'Portatif disk (Floppy)';
dtFixed : diskinfos.disk_Tip := 'Sabit disk';
dtRemote : diskinfos.disk_Tip := 'Uzak veya ağ sürücüsü';
dtCDROM : diskinfos.disk_Tip := 'CD-ROM sürücü';
dtRamDrive : diskinfos.disk_Tip := 'RAM sürücü';
end;
//Diskteki toplam ve boş alan bilgisini al (MB)
GetDiskFreeSpace(PChar(drv), SectPerCls, BytesPerCls, FreeCls, TotCls);
diskinfos.bos_yer:=FormatFloat('0.00', (SectPerCls * BytesPerCls * FreeCls)/1000000) + ' MB';
diskinfos.Top_Yer:= FormatFloat('0.00', (SectPerCls * BytesPerCls * TotCls)/1000000) + ' MB';
//Hafızayı temizle
FreeMem(pVolName, MAX_PATH);
FreeMem(pFSBuf, MAX_PATH);
FreeMem(nVNameSer, MAX_PATH);
end;
Bir dosyanın tarih ve saat bilgisinin alınması
procedure TForm1.Button1Click(Sender: TObject);
var
TheFileDate: string;
Fhandle: integer;
begin
FHandle := FileOpen('C:COMMAND.COM', 0);
Try
TheFileDate :=
DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
finally
FileClose(FHandle);
end;
SHOWMESSAGE(THEFILEDATE);
end;
Bir klasörün özelliğinin değiştirilmesi
Aşağıdaki kod örneğinde, bir klasörün "Hidden" özelliği değiştirilmektedir.
Function DirectoryHide(Const FileString : String): Boolean;
Var
Attributes : Integer;
Begin
Result := False;
Try
If Not DirectoryExists(FileString) Then Exit;
Attributes := faDirectory + faHidden + faSysFile;
FileSetAttr(FileString,Attributes);
Result := True;
Except
End;
End;
---
Function DirectoryUnHide(Const FileString : String): Boolean;
Var
Attributes : Integer;
Begin
Result := False;
Try
If Not DirectoryExists(FileString) Then Exit;
Attributes := faDirectory;
FileSetAttr(FileString,Attributes);
Result := True;
Except
End;
End;
Dosyanın sürüklenip bırakılması
Fare ile sürüklenerek, aşağıdaki unite bağlı form üzerine dosya bırakıldığında, bırakılan dosyanın dizini ve adı tespit edilmektedir.
unit dragfile;
interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs;
type
TForm2 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure AcceptFiles( var msg : TMessage );
message WM_DROPFILES;
end;
var
Form2: TForm2;
implementation
uses
ShellAPI;
{$R *.DFM}
procedure TForm2.AcceptFiles( var msg : TMessage );
const
cnMaxFileNameLen = 255;
var
i,
nCount : integer;
acFileName : array [0..cnMaxFileNameLen] of char;
begin
nCount := DragQueryFile( msg.WParam,
$FFFFFFFF,
acFileName,
cnMaxFileNameLen );
for i := 0 to nCount-1 do
begin
DragQueryFile( msg.WParam, i,
acFileName, cnMaxFileNameLen );
MessageBox( Handle, acFileName, '', MB_OK );
end;
DragFinish( msg.WParam );
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
DragAcceptFiles( Handle, True );
end;
end.