Добавляем дополнительную кнопку в заголовок формы

Falk0ner, вс, 06/07/2008 - 15:34.

Манипуляции с заголовком формы

Автор: Vimil Saju
Чтобы добавить дополнительную кнопку, нам прийдётся создать обработчики для следующих событий:
WM_NCPAINT;//вызывается, когда перерисовывается не клиентская область формы
WM_NCACTIVATE; вызывается, когда заголовок формы становится активныи
WM_NCLBUTTONDOWN; вызывается, когда кнопка мыши нажимается на не клиентской области
WM_NCMOUSEMOVE; вызывается, когда курсор мыши передвигается по не клиентской области
WM_MOUSEMOVE;вызывается, когда курсор мыши передвигается по клиентской области
WM_LBUTTONUP; вызывается, когда кнопка мыши отпушена в клиентской области
WM_NCLBUTTONUP; вызывается, когда кнопка мыши отпушена в не клиентской области
WM_NCLBUTTONDBLCLK; вызывается при двойном щелчке мышкой в не клиентской области
Приведённый ниже код модифицирован, чтобы избавиться от нежелательного мерцания кнопки
будем использовать следующие переменные:
h1(Thandle) : хэндл контекста устройства всего окна, включая не клиентскую область.
pressed(boolean): индикатор, показывающий, нажата кнопка или нет.
focuslost(boolean): индикатор, показывающий, находится ли фокус на кнопке или нет.
rec(Trect): размер кнопки.

type

TForm1 = class(TForm)

procedure FormPaint(Sender: TObject);

procedure FormResize(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

procedure WMNCPAINT(var msg:tmessage);message WM_NCPAINT;

procedure WMNCACTIVATE(var msg:tmessage);message WM_NCACTIVATE;

procedure WMNCMOUSEDOWN(var msg:tmessage);message WM_NCLBUTTONDOWN;

procedure WMNCMOUSEMOVE(var msg:tmessage);message WM_NCMOUSEMOVE;

procedure WMMOVE(var msg:tmessage);message WM_MOUSEMOVE;

procedure WMLBUTTONUP(var msg:tmessage);message WM_LBUTTONUP;

procedure WMNCMOUSEUP(var msg:tmessage);message WM_NCLBUTTONUP;

procedure WNCLBUTTONDBLCLICK(var msg:tmessage);message WM_NCLBUTTONDBLCLK;

end;

var

Form1: TForm1;

h1:thandle;

pressed:boolean;

focuslost:boolean;

rec:trect;

implementation

{$R *.DFM}

procedure tform1.WMLBUTTONUP(var msg:tmessage);

begin

pressed:=false;

invalidaterect(form1.handle,@rec,true);

inherited;

end;

procedure tform1.WMMOVE(var msg:tmessage);

var tmp:boolean

begin

tmp:=focuslost;

focuslost:=true;

if tmp<>focuslost then

invalidaterect(form1.handle,@rec,true);

inherited;

end;

procedure tform1.WMNCMOUSEMOVE(var msg:tmessage);

var

pt1:tpoint;

tmp:boolean;

begin

tmp:=focuslost;

pt1.x:=msg.LParamLo-form1.left;

pt1.y:=msg.LParamHi-form1.top;

if not(ptinrect(rec,pt1)) then

focuslost:=true

else

focuslost:=false;

if tmp<>focuslost then

invalidaterect(form1.handle,@rec,true);

end;

procedure tform1.WNCLBUTTONDBLCLICK(var msg:tmessage);

var pt1:tpoint;

begin

pt1.x:=msg.LParamLo-form1.left;

pt1.y:=msg.LParamHi-form1.top;

if not(ptinrect(rec,pt1)) then

inherited;

end;

procedure tform1.WMNCMOUSEUP(var msg:tmessage);

var pt1:tpoint;

begin

pt1.x:=msg.LParamLo-form1.left;

pt1.y:=msg.LParamHi-form1.top;

if (ptinrect(rec,pt1)) and (focuslost=false) then

begin

pressed:=false;

{

enter your code here when the button is clicked

}

invalidaterect(form1.handle,@rec,true);

end

else

begin

pressed:=false;

focuslost:=true;

inherited;

end;

end;

procedure tform1.WMNCMOUSEDOWN(var msg:tmessage);

var pt1:tpoint;

begin

pt1.x:=msg.LParamLo-form1.left;

pt1.y:=msg.LParamHi-form1.top;

if ptinrect(rec,pt1) then

begin

pressed:=true;

invalidaterect(form1.handle,@rec,true);

end

else

begin

form1.paint;

inherited;

end;

end;

procedure tform1.WMNCACTIVATE(var msg:tmessage);

begin

invalidaterect(form1.handle,@rec,true);

inherited;

end;

procedure tform1.WMNCPAINT(var msg:tmessage);

begin

invalidaterect(form1.handle,@rec,true);

inherited;

end;

procedure TForm1.FormPaint(Sender: TObject);

begin

h1:=getwindowdc(form1.handle);

rec.left:=form1.width-75;

rec.top:=6;

rec.right:=form1.width-60;

rec.bottom:=20;

selectobject(h1,getstockobject(ltgray_BRUSH));

rectangle(h1,rec.left,rec.top,rec.right,rec.bottom);

if (pressed=false) or (focuslost=true) then

drawedge(h1,rec,EDGE_RAISED,BF_RECT)

else if (pressed=true) and (focuslost=false) then

drawedge(h1,rec,EDGE_SUNKEN,BF_RECT);

releasedc(form1.handle,h1);

end;

procedure TForm1.FormResize(Sender: TObject);

begin

form1.paint;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

rec.left:=0;

rec.top:=0;

rec.bottom:=0;

rec.right:=0;

end;

Комментарии специалистов:
Дата: 25 Августа 2000г.
Автор: NeNashev nashev@mail.ru
InvalidateRect на событие Resize ничего не даёт. Но даже без него
кнопка всё равно моргает при Resize формы... Надо ещё где-то убрать
Для рисования кнопок на заголовке окна лучше пользоваться
DrawFrameControl а не DrawEdge... Так и с не серыми настройками
интерфейса всё правильно будет. Да и проще так.
Названия функций, констант и т.п лучше писать так, как они в описаниях
даются, а не подряд маленькими буквами. Особенно для публикации. Так
оно и читается по большей части лучше, и в С такая привычка Вам не
помешает...
Сравнивать логическое значение с логической константой чтоб получить
логическое значение глупо, так как логическое значение у Вас уже есть.
тоесь вместо
if (pressed=true) and (focuslost=false)
лучше писать
if Pressed and not FocusLost
Для конструирования прямоугольников и точек из координат есть две
простые функции Rect и Point.

В общем Ваша процедура FormPaint может выглядеть так:

procedure TMainForm.FormPaint(Sender: TObject);

var h1:THandle;

begin

h1:=GetWindowDC(MainForm.Handle);

rec:=Rect(MainForm.Width-75,6,MainForm.Width-60,20);

if Pressed and not FocusLost then

DrawFrameControl(h1, rec, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_PUSHED)

else

DrawFrameControl(h1, rec, DFC_BUTTON, DFCS_BUTTONPUSH);

ReleaseDC(MainForm.Handle,h1);

end;

Но вообще-то рисовать эту кнопку надо только при WM_NCPAINT, а не
всегда... И вычислять координаты по другому... Вдруг размер элементов
заголовка у юзера в системе не стандартный? А это просто настраивается...
Взято из http://forum.sources.ru

Непосредственно такой функции вроде нет, но можно изловчиться. Нарисовать там кнопку вручную и обрабатывать команды нажатия мышки на Caption Bar.
Пример.

unit Main;

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

//Dimensions of Sizeable Frame

xFrame := GetSystemMetrics(SM_CXFRAME);

yFrame := GetSystemMetrics(SM_CYFRAME);

//Dimensions of Caption Buttons

xSize := GetSystemMetrics(SM_CXSIZE);

ySize := GetSystemMetrics(SM_CYSIZE);

//Define the placement of the new caption button

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

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

//Get the handle to canvas using Form's device context

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);

//Define a smaller drawing rectangle within the button

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

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

with CaptionBtn do

Canvas.TextRect(R, R.Left + 2, R. - 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 - )) then

Result := htCaptionBtn;

end;

procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);

begin

inherited;

if (Msg.HitTest = htCaptionBtn) then

ShowMessage('You hit the button on the caption bar');

end;

procedure TForm1.FormResize(Sender: TObject);

begin

//Force a redraw of caption bar if form is resized

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

end;

end.

Источник: http://dmitry9.nm.ru/info/

Автор: Tercio Ferdinando Gaudencio Filho
Приведённый здесь код создаёт кнопку в заголовке окна, создаёт MenuItem в системном меню и создаёт подсказку(Hint) в кнопке. Поместите код в Ваш Unit и замените "FrmMainForm" на Ваше имя формы, а так же некоторые кусочки кода, ткст подсказки и т.д.
Совместимость: Delphi 3.x (или выше)

...

private

{ Private declarations }

procedure WMNCPAINT (var msg: Tmessage); message WM_NCPAINT;

procedure WMNCACTIVATE (var msg: Tmessage); message WM_NCACTIVATE;

procedure WMNCMOUSEDOWN (var msg: Tmessage); message WM_NCLBUTTONDOWN;

procedure WMNCMOUSEMOVE (var Msg: TMessage); message WM_NCMOUSEMOVE;

procedure WMMOUSEMOVE (var Msg: TMessage); message WM_MOUSEMOVE;

procedure WMLBUTTONUP (var msg: Tmessage); message WM_LBUTTONUP;

procedure WNCLBUTTONDBLCLICK (var msg: Tmessage); message WM_NCLBUTTONDBLCLK;

procedure WMNCRBUTTONDOWN (var msg: Tmessage); message WM_NCRBUTTONDOWN;

procedure WMNCHITTEST (var msg: Tmessage); message WM_NCHITTEST;

procedure WMSYSCOMMAND (var msg: Tmessage); message WM_SYSCOMMAND;

...

var

...

Pressed : Boolean;

FocusLost : Boolean;

Rec : TRect;

NovoMenuHandle : THandle;

PT1 : TPoint;

FHintshow : Boolean;

FHint : THintWindow;

FHintText : String;

FHintWidth : Integer;

...

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMSYSCOMMAND(var Msg: TMessage);

begin

if Msg.WParam=LongInt(NovoMenuHandle) then

//*********************************************

//Кнопка была нажата! Добавьте сюда Вашу функцию

//*********************************************

inherited;

end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCHITTEST(var Msg: TMessage);

var

Tmp : Boolean;

begin

if Pressed then

begin

Tmp:=FocusLost;

PT1.X := Msg.LParamLo - FrmMainForm.Left;

PT1.Y := Msg.LParamHi - FrmMainForm. ;

if PTInRect(Rec, PT1) then

FocusLost := False

else

FocusLost := True;

if FocusLost <> Tmp then

InvalidateRect(FrmMainForm.Handle, @Rec, True);

end;

inherited;

end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMLBUTTONUP(var Msg: TMessage);

var

Tmp : Boolean;

begin

ReleaseCapture;

Tmp := Pressed;

Pressed := False;

if Tmp and PTInRect(Rec, PT1) then

begin

InvalidateRect(FrmMainForm.Handle, @Rec, True);

FHintShow := False;

FHint.ReleaseHandle;

//*********************************************

//Кнопка была нажата! Добавьте сюда Вашу функцию

//*********************************************

end

else

inherited;

end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WNCLBUTTONDBLCLICK(var Msg: TMessage);

begin

PT1.X := Msg.LParamLo - FrmMainForm.Left;

PT1.Y := Msg.LParamHi - FrmMainForm. ;

if not PTInRect(Rec, PT1) then

inherited;

end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCRBUTTONDOWN(var Msg: TMessage);

begin

PT1.X := Msg.LParamLo - FrmMainForm.Left;

PT1.Y := Msg.LParamHi - FrmMainForm. ;

if not PTInRect(Rec, PT1) then

inherited;

end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCMOUSEDOWN(var Msg: TMessage);

begin

PT1.X := Msg.LParamLo - FrmMainForm.Left;

PT1.Y := Msg.LParamHi - FrmMainForm. ;

FHintShow := False;

if PTInRect(Rec, PT1) then

begin

Pressed := True;

FocusLost := False;

InvalidateRect(FrmMainForm.Handle, @Rec, True);

SetCapture(TWinControl(FrmMainForm).Handle);

end

else

begin

FrmMainForm.Paint;

inherited;

end;

end;

//------------------------------------------------------------------------------

//That function Create a Hint

procedure TFrmMainForm.WMNCMOUSEMOVE(var Msg: TMessage);

begin

PT1.X := Msg.LParamLo - FrmMainForm.Left;

PT1.Y := Msg.LParamHi - FrmMainForm. ;

if PTInRect(Rec, PT1) then

begin

FHintWidth := FHint.Canvas.TextWidth(FHintText);

if (FHintShow = False) and (Length(Trim(FHintText)) <> 0) then

FHint.ActivateHint(

Rect(

Mouse.CursorPos.X,

Mouse.CursorPos.Y + 20,

Mouse.CursorPos.X + FHintWidth + 10,

Mouse.CursorPos.Y + 35

),

FHintText

);

FHintShow := True;

end

else

begin

FHintShow := False;

FHint.ReleaseHandle;

end;

end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMMOUSEMOVE(var Msg: TMessage);

begin

FHintShow := False;

FHint.ReleaseHandle;

end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCACTIVATE(var Msg: TMessage);

begin

InvalidateRect(FrmMainForm.Handle, @Rec, True);

inherited;

end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.WMNCPAINT(var Msg: TMessage);

begin

InvalidateRect(FrmMainForm.Handle, @Rec, True);

inherited;

end;

//------------------------------------------------------------------------------

procedure TFrmMainForm.FormPaint(Sender:TObject);

var

Border3D_Y, Border_Thickness, Btn_Width,

Button_Width, Button_Height : Integer;

MyCanvas : TCanvas;

begin

MyCanvas := TCanvas.Create;

MyCanvas.Handle := GetWindowDC(FrmMainForm.Handle);

Border3D_Y := GetSystemMetrics(SM_CYEDGE);

Border_Thickness:= GetSystemMetrics(SM_CYSIZEFRAME);

Button_Width := GetSystemMetrics(SM_CXSIZE);

Button_Height := GetSystemMetrics(SM_CYSIZE);

//Создаём квадратную кнопку, но если Вы захотите создать кнопку другого размера, то

//измените эту переменную на Вашу ширину.

Btn_Width := Border3D_Y + Border_Thickness + Button_Height - (2 * Border3D_Y) - 1;

Rec.Left := FrmMainForm.Width - (3 * Button_Width + Btn_Width);

Rec.Right := FrmMainForm.Width - (3 * Button_Width + 03);

Rec. := Border3D_Y + Border_Thickness - 1;

Rec.Bottom := Rec. + Button_Height - (2 * Border3D_Y);

FillRect(MyCanvas.Handle,Rec,HBRUSH(COLOR_BTNFACE+1));

If not Pressed or Focuslost Then

DrawEdge(MyCanvas.Handle, Rec, EDGE_RAISED, BF_SOFT or BF_RECT)

Else If Pressed and Not Focuslost Then

DrawEdge(MyCanvas.Handle, Rec, EDGE_SUNKEN, BF_SOFT or BF_RECT);

//It draw a the application icon to the button. Easy to change.

DrawIconEX(MyCanvas.Handle, Rec.Left+4, Rec.+3, Application.Icon, 8, 8, 0, 0, DI_NORMAL);

MyCanvas.Free;

end;

...

procedure TFrmMainForm.FormCreate(Sender: TObject);

...

InsertMenu(GetSystemMenu(Handle,False), 4, MF_BYPOSITION+MF_STRING, NovoMenuHandle,pchar('TEXT OF THE MENU'));

Rec := Rect(0,0,0,0);

FHintText := 'Put the text of your Hint HERE';

FHint := THintWindow.Create(Self);

FHint.Color := clInfoBk; //Вы можете изменить бэкграунд подсказки

...

Взято из http://forum.sources.ru

DelphiSite

Наиболее читаемое

Добавляем дополнительную кнопку в заголовок формы

Отправить комментарий

Похожие материалы

Быстрая навигация в FAQ

Новые файлы