Содержание материала

 

Автор: 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): размер кнопки.


Code:

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;

 


Комментарии специалистов:

 

InvalidateRect на событие Resize ничего не даёт. Но даже без него

кнопка всё равно моргает при Resize формы... Надо ещё где-то убрать

 

Для рисования кнопок на заголовке окна лучше пользоваться

DrawFrameControl а не DrawEdge... Так и с не серыми настройками

интерфейса всё правильно будет. Да и проще так.

 

Названия функций, констант и т.п лучше писать так, как они в описаниях

даются, а не подряд маленькими буквами. Особенно для публикации. Так

оно и читается по большей части лучше, и в С такая привычка Вам не

помешает...

 

Сравнивать логическое значение с логической константой чтоб получить

логическое значение глупо, так как логическое значение у Вас уже есть.

тоесь вместо

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

лучше писать

if Pressed and not FocusLost

 

Для конструирования прямоугольников и точек из координат есть две

простые функции Rect и Point.

 

 

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

Code:

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, а не

всегда... И вычислять координаты по другому... Вдруг размер элементов

заголовка у юзера в системе не стандартный? А это просто настраивается... 


 

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

Пример.

 

Code:

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.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('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.

 


Автор: Tercio Ferdinando Gaudencio Filho

 

Приведённый здесь код создаёт кнопку в заголовке окна, создаёт MenuItem в системном меню и создаёт подсказку(Hint) в кнопке. Поместите код в Ваш Unit и замените "FrmMainForm" на Ваше имя формы, а так же некоторые кусочки кода, ткст подсказки и т.д.

 

Совместимость: Delphi 3.x (или выше)

Code:

...

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.Top ;

   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.Top ;

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.Top ;

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.Top ;

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.Top ;

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.Top    := Border3D_Y  + Border_Thickness - 1;

Rec.Bottom := Rec.Top     + 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.Top+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;  //Вы можете изменить бэкграунд подсказки

 ...

 

 

Добавить комментарий

Не использовать не нормативную лексику.

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

ВСЕ КОММЕНТАРИИ МОДЕРИРУЮТСЯ ВРУЧНУЮ, ТАК ЧТО СПАМИТЬ БЕСПОЛЕЗНО!


Защитный код
Обновить