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

Delphi , Программа и Интерфейс , Заголовок формы

Оформил: DeeCo

Автор: 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г.
Автор: NeNashevnashev@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, WM_NCACTIVATE и других.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: Заголовок формы ::