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;
end;
function DummyWindowProc (Wnd: hWnd; Msg, wParam: Word; lParam: LongInt): LongInt; stdcall;
var
TrayHandle: THandle;
dc: hDC;
i: Integer;
pm: HMenu;
pt: TPoint;
begin
DummyWindowProc := 0;
StrPCopy(@WndClass[0], 'Progman');
TrayHandle := FindWindow(@WndClass[0], nil);
case Msg of
wm_Create:
begin
tid.cbSize := sizeof (tid);
tid.Wnd := Wnd;
tid.uID := 1;
tid.uFlags := nif_Message or nif_Icon or nif_Tip;
tid.uCallBackMessage := wm_User;
tid.hIcon := LoadIcon (hInstance, 'MAINICON');
lstrcpy (tid.szTip,'Desktop is on');
Shell_NotifyIcon (nim_Add, @tid);
end;
wm_Destroy:
begin
Shell_NotifyIcon (nim_Delete, @tid);
PostQuitMessage (0);
ShowWindow(TrayHandle, SW_RESTORE);
end;
wm_Command:
begin
HandleCommand (Wnd, LoWord (wParam));
Exit;
end;
wm_User: // Had a tray notification - see what to do
if (lParam = wm_LButtonDown) then
begin
if x = 0 then
begin
ShowWindow(TrayHandle, SW_HIDE);
//tid.hIcon := LoadIcon (hInstance, 'offICON');
lstrcpy (tid.szTip,'Desktop Kapalı');
Shell_NotifyIcon (NIM_MODIFY, @tid);
x:=1
end else
begin
ShowWindow(TrayHandle, SW_RESTORE);
//tid.hIcon := LoadIcon (hInstance, 'ONICON');
lstrcpy (tid.szTip,'Desktop Açık');
Shell_NotifyIcon (NIM_MODIFY, @tid);
x:= 0;
end;
end else
if (lParam = wm_RButtonDown) then
begin
GetCursorPos (pt);
pm := CreatePopupMenu;
AppendMenu (pm, 0, Ord ('A'), 'Hakkında...');
AppendMenu (pm, mf_Separator, 0, Nil);
AppendMenu (pm, 0, Ord ('E'), 'Kapat');
SetForegroundWindow (Wnd);
dc := GetDC (0);
if TrackPopupMenu (pm, tpm_BottomAlign or tpm_RightAlign, pt.x,GetDeviceCaps(dc,HORZRES){pt.y}, 0, Wnd, Nil) then
SetForegroundWindow (Wnd);
DestroyMenu (pm)
end;
end;
DummyWindowProc := DefWindowProc (Wnd, Msg, wParam, lParam);
end;
procedure WinMain;
var
Wnd: hWnd;
Msg: TMsg;
cls: TWndClass;
begin
{ Previous instance running ? If so, exit }
if FindWindow (AppName, Nil) <> 0 then exit;
//Panic (AppName + ' is already running.');
{ window Sınıfını kaydettir }
FillChar (cls, sizeof (cls), 0);
cls.lpfnWndProc := @DummyWindowProc;
cls.hInstance := hInstance;
cls.lpszClassName := AppName;
RegisterClass (cls);
{ Boş pencereyi yarat }
Wnd := CreateWindow (AppName, AppName, ws_OverlappedWindow,
cw_UseDefault, cw_UseDefault, cw_UseDefault, cw_UseDefault,
0, 0, hInstance, Nil);
x:= 0;
if Wnd <> 0 then
begin
ShowWindow (Wnd, sw_Hide);
while GetMessage (Msg, 0, 0, 0) do
begin
TranslateMessage (Msg);
DispatchMessage (Msg);
end;
end;
end;
begin
WinMain;
end.
Bütün açı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
i,
nCount : integer;
acFileName : array [0..cnMaxFileNameLen] of char;
begin
nCount := DragQueryFile( msg.WParam,
$FFFFFFFF,
acFileName,
cnMaxFileNameLen );
for i := 0 to nCount-1 do
begin
DragQueryFile( msg.WParam, i,
acFileName, cnMaxFileNameLen );
MessageBox( Handle, acFileName, '', MB_OK );
end;
DragFinish( msg.WParam );
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
DragAcceptFiles( Handle, True );
end;
end.
Form baş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
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;
end;
Bu işlemden sonra kontrollerdeki yazı tiplerinin de ölçeklenmesi gerekecektir. Bu işlem bir döngü içerisinde kolaylıkla yapılır. Fakat bu esnada ilgili bileşenin FONT özelliği bulunduğundan emin olunmalıdır. Bu kontrol için RTTI (Run Time Type Information) kullanılabilir.
USES typinfo;
var
i: integer;
begin
for i := componentCount - 1 downto 0 do
with components[i] do
begin
if GetPropInfo(ClassInfo, 'font') <> nil then
font.size := (NewFormWidth DIV OldFormWidth) * font.size;
end;
end;
Form baş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;
end;
procedure tform1.goster;
var
save:longint;
begin
if borderstyle=bsnone then exit;
save:=getwindowlong(handle,gwl_style);
if (save and ws_caption)<>ws_caption then
begin
case borderstyle of
bssingle,
bssizeable: setwindowlong(handle,gwl_style,save or ws_caption or ws_border);
bsdialog:setwindowlong(handle,gwl_style,save or ws_caption or ds_modalframe or ws_dlgframe);
end;
height:=height+getsystemmetrics(sm_cycaption);
refresh;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
sakla
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
goster
end;
end.
