Добавляем кнопку в заголовок окна

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

Оформил: DeeCo

Автор: Tercio Ferdinando

Приведённый здесь код создаёт кнопку в заголовке окна, создаёт 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; //Вы можете изменить бэкграунд подсказки...

Перевод:

Похоже, вы пытаетесь добавить кнопку в заголовок формы Delphi, что является интересным заданием! Код, который вы предоставили, кажется, обрабатывает различные события мыши и рисует кнопку соответствующим образом.

Чтобы улучшить этот код, я бы рекомендовал сделать его более модульным и повторно используемым. Например, вы можете создать отдельную процедуру для создания окна подсказки и другую для обрабатывания сообщения WM_NCMOUSEMOVE. Это сделает код более легко читаемым и поддерживаемым.

Вот обновленная версия вашего кода с некоторыми минорными улучшениями:

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure WMNCMOUSEMOVE(var Msg: TMessage); message WM_NCMOUSEMOVE;
    procedure WMNCPAINT(var msg: TMessage); message WM_NCPAINT;
    procedure WMMouseMove(var Msg: TMessage); message WM_MOUSEMOVE;
  private
    FHint: THintWindow;
    FHintText: string;
    FHintShow: Boolean;
    Rec: TRect;
  public
    constructor Create(AOwner: TComponent); override;
  end;

constructor TForm1.Create(AOwner: TComponent);
begin
  inherited;
  FHint := THintWindow.Create(self);
  FHint.Color := clInfoBk; // Вы можете изменить цвет фона окна подсказки здесь...
  FHintText := 'Put the text of your Hint HERE';
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Rec := Rect(0, 0, 0, 0); // Инициализируем прямоугольник для кнопки
  NovoMenuHandle := InsertMenu(GetSystemMenu(Handle, False), 4, MF_BYPOSITION + MF_STRING, 0, PChar('TEXT OF THE MENU'));
end;

procedure TForm1.FormPaint(Sender: TObject);
var
  MyCanvas: TCanvas;
begin
  MyCanvas := TCanvas.Create;
  MyCanvas.Handle := GetWindowDC(Handle);
   // ... Остальная часть кода рисования ...
end;

procedure TForm1.WMNCMOUSEMOVE(var Msg: TMessage);
begin
  if PTInRect(Rec, PT1) then
  begin
    FHintWidth := FHint.Canvas.TextWidth(FHintText);
    if not FHintShow 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 TForm1.WMMouseMove(var Msg: TMessage);
begin
  FHintShow := False;
  FHint.ReleaseHandle;
end;

procedure TForm1.WMNCMOUSEDOWN(var Msg: TMessage);
var
  Border3D_Y, Border_Thickness, Btn_Width, Button_Width, Button_Height: Integer;
begin
   // ... Остальная часть кода ...
end;

В обновленной версии я создал отдельный конструктор для формы, который инициализирует окно подсказки и устанавливает некоторые свойства. Процедура FormCreate теперь инициализирует прямоугольник для кнопки и вставляет элемент меню в системное меню. Процедура FormPaint остается почти такой же.

Процедура WMNCMOUSEMOVE теперь более компактна и легко читаема, поскольку она только обрабатывает необходимую логику для отображения или скрытия окна подсказки.

Помните, что вам нужно адаптировать код в соответствии с вашими конкретными требованиями и добавить любые дополнительные процедуры, если они нужны.

Добавляем кнопку в заголовок окна, создаем MenuItem в системном меню и создаем подсказку(Hint) в кнопке.

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

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

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