Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

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

01.01.2007

Автор: 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, а не

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

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

Взято из https://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.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.

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

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