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

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