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

Автор: 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, а не
всегда... И вычислять координаты по другому... Вдруг размер элементов
заголовка у юзера в системе не стандартный? А это просто настраивается...


Взято с Исходников.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.