Delphi World - Добавляем дополнительную кнопку в заголовок формы
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Добавляем дополнительную кнопку в заголовок формы

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