Рисование на неклиентской часть окна

Aptyp · 27 июля, 2023

Здравствуйте. Есть ли какая-либо возможность в Firemonkey для Windows поместить компонент или хотя бы рисовать на неклиентской части формы, а именно на TitleBar? В VCL для этого даже компонент отдельный сделали TTitleBarPanel. Перерыл весь Google и нечего вообще по теме не нашёл.

Изменено 27 июля, 2023 пользователем Aptyp

Martifan · 27 июля, 2023

К сожалению, в FireMonkey для Windows нет встроенной поддержки для размещения компонентов или рисования на заголовке окна (title bar).

Однако, есть несколько возможных вариантов для достижения похожего эффекта:

Создать собственный кастомный компонент на основе TControl, который будет перекрывать заголовок окна и имитировать его. Можно нарисовать свой фон, кнопки и т.д.
Использовать Windows API функции для настройки и изменения заголовка окна. Например, SetWindowText, SetWindowLong и другие. Это более сложный подход, но дает больше контроля.
Рассмотреть сторонние компоненты и библиотеки. Возможно, кто-то уже реализовал похожую функциональность для FireMonkey.
Попробовать поместить TControlAboveTarget на TForm и настроить его позицию/размер чтобы перекрывал заголовок. Не идеальный вариант, но может сработать.

Так что в целом это возможно реализовать в FireMonkey, но нет встроенного прямого решения как в VCL. Придется поиграться с кастомными компонентами и низкоуровневым API.

OnePeople · 28 июля, 2023

Или просто сделайте borderstyle формы none. И сами сделайте рамки, кнопки закрыть, свернуть и т.д.

Aptyp · 29 июля, 2023

В 28.07.2023 в 10:41, OnePeople сказал:

Или просто сделайте borderstyle формы none. И сами сделайте рамки, кнопки закрыть, свернуть и т.д.

Не лучший вариант, так как теряется нормальная возможность изменять размер окна и перемещение с привязкой к краям экрана, когда система предлагает развернуть экран на пол экрана или в угол поместить

Aptyp · 31 июля, 2023

В общем рисовать как оказалось на неклиентской части формы вообще не проблема. Но я делаю форму Acrylic (Полупрозрачную с размытым фоном), и вот тут появляются проблемы. Если рисовать обычным способом, как на Canvas, то цвет получается тоже полупрозрачный. Путём экспериментов выяснил, что относительно нормально рисуется таким методом:

uses Winapi.Windows;

BitBlt( GetWindowDC( WindowHandleToPlatform( Form.Handle ).Wnd ), 0, 0, BitMap.Width, BitMap.Height, BitMap.Canvas.Handle, 0, 0, cmMergePaint );

В обычном случае последний аргумент должен быть cmSrcCopy, но с ним тоже получается полупрозрачная картинка. Помогает только cmMergePaint, НО! таким способом рисуется картинка с инвертированными цветами. То есть перед таким рисованием нужно её самому инвертировать.

Следующий шаг – это рисовать png картинку, так как редко надо рисовать просто непрозрачную прямоугольную картинку. С 32-битным TBitMap у меня пока что-то не получилось, а вот TPngImage вполне хорошо рисуется.

uses FMX.Platform.Win, Winapi.Windows, Vcl.Graphics, Vcl.Imaging.pngimage;

function TForm1.WinHandle: HWND;
begin
  Result := WindowHandleToPlatform( Self.Handle ).Wnd;
end;

procedure TForm1.FormPaint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF);
var
  ACanvas: Vcl.Graphics.TCanvas;
  png: TPngImage;
begin
  ACanvas := Vcl.Graphics.TCanvas.Create;
  ACanvas.Handle := GetWindowDC(Self.WinHandle);
  png := TPngImage.Create;
  png.LoadFromFile('C:\Image.png');
  try
    PatBlt( ACanvas.Handle, 0, 0, png.Width, png.Height, cmBlackness );
    png.Draw( ACanvas, Rect( 0, 0, png.Width, png.Height ) );
  finally
    ReleaseDC(Self.WinHandle, ACanvas.Handle);
    ACanvas.Handle := 0;
    ACanvas.DisposeOf;
    png.DisposeOf;
  end;
end;

Но и тут есть подводные камни. Метод TPngImage.Draw, если заглянуть в его код становится понятно, что рисует он поверх того, что уже нарисовано и картина накладывается одна на другую быстро теряя прозрачность полупрозрачных пикселей. Поэтому перед её рисованием нужно стереть, что было до этого, с чем отлично справляется функция Winapi.Windows.PatBlt. Но таким образом появляется мерцание.

А так же я ещё не нашёл, как отловить в FireMonkey отловить у формы событие WM_NCPAINT. Пока что навесил рисование на событие формы OnPaint, но оно не стабильно работает в данном случае и бывает, когда картинка стирается и не рисуется, пока не наступит надобность перерисовать клиентскую часть формы.

Изменено 31 июля, 2023 пользователем Aptyp

OnePeople · 1 августа, 2023

Canvas.lock

Canvas.Unlock

Помогает с мерцанием

В 29.07.2023 в 22:53, Aptyp сказал:

Не лучший вариант, так как теряется нормальная возможность изменять размер окна и перемещение с привязкой к краям экрана, когда система предлагает развернуть экран на пол экрана или в угол поместить

изменять размер окна - легко реализуемо

перемещение с привязкой к краям экрана, когда система предлагает развернуть экран на пол экрана или в угол поместить -

это да, но никаких проблем с размещение любых компонентов и рисованием любых рисунков.

Dmitry_4501 · 2 августа, 2023

В 01.08.2023 в 20:16, OnePeople сказал:

изменять размер окна - легко реализуемо

перемещение с привязкой к краям экрана, когда система предлагает развернуть экран на пол экрана или в угол поместить -

это да, но никаких проблем с размещение любых компонентов и рисованием любых рисунков.

Подключусь к теме...

Как-то пытался сделать подобное и в принципе получилось, безрамочное окно, которое по-нативному работает, что удалось заставить работать:

Если взять окно за заголовок и начать двигать им туда-сюда, то все остальные окна свернутся - нативное поведение
Если взять окно за заголовок то в Windows 11 появляется верхнее меню с макетами отображения на экране - нативное поведение
Если взять окно за заголовок и перетащить его к одному из краев экрана, то появится макет для отображения окна - нативное поведение
Нативным образом реализовано изменение размера за все края формы, включая диагональные.
Так же окно имеет нативные анимации появления\исчезания, разворачивания\сворачивания
Так же имеется нативная тень
А на Windows 11 имеются закруглённые края окна

Что не получилось:

Не получилось реализовать нативное поведение, когда в Windows 11 наводишь курсор на кнопку "развернуть окно", там появляется небольшое меню с макетами отображения на экране.
Нормально реализовать границы для изменения размеров окна, ибо из-коробки они находятся за пределами окна в поле где тень у окна (в Windows 10 и Windows 11 так), у меня же они внутри окна. Как-то делал и получалось, но уже не помню.

Код несложно адаптировать и под FireMonkey

BorderlessWindowWithAeroSnap.zip

Изменено 2 августа, 2023 пользователем Dmitry_4501

Aptyp · 2 августа, 2023

@Dmitry_4501 Спасибо, очень классный пример. Те пункты, которые не получились – это уже не столь важно.

Но есть одна проблема, то ли я дурак, то ли лыжи не едут, но FireMonkey вообще никак не реагирует на следующие команды:

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_CLOSE, 0);

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_MINIMIZE, 0);

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_MAXIMIZE, 0);

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_RESTORE, 0);

При этом команда перемещения отрабатывает штатно:

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, $F012, 0);

P.S. Рекомендую Position всегда ставить poScreenCenter. Так как при poDesktopCenter и наличии нескольких мониторов форма появляется между экранами, а не в центе одного из них. Я это сам обнаружил только, когда подключил себе второй монитор.

Dmitry_4501 · 3 августа, 2023

16 часов назад, Aptyp сказал:
@Dmitry_4501 Спасибо, очень классный пример. Те пункты, которые не получились – это уже не столь важно.

Но есть одна проблема, то ли я дурак, то ли лыжи не едут, но FireMonkey вообще никак не реагирует на следующие команды:
SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_CLOSE, 0);

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_MINIMIZE, 0);

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_MAXIMIZE, 0);

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_RESTORE, 0);
При этом команда перемещения отрабатывает штатно:
SendMessage(FormToHWND(Self), WM_SYSCOMMAND, $F012, 0);
P.S. Рекомендую Position всегда ставить poScreenCenter. Так как при poDesktopCenter и наличии нескольких мониторов форма появляется между экранами, а не в центе одного из них. Я это сам обнаружил только, когда подключил себе второй монитор.

Хм, странно. Должно работать. Сейчас открою проект еще раз у себя. Гляну.

Dmitry_4501 · 3 августа, 2023

16 часов назад, Aptyp сказал:
@Dmitry_4501 Спасибо, очень классный пример. Те пункты, которые не получились – это уже не столь важно.

Но есть одна проблема, то ли я дурак, то ли лыжи не едут, но FireMonkey вообще никак не реагирует на следующие команды:
SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_CLOSE, 0);

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_MINIMIZE, 0);

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_MAXIMIZE, 0);

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_RESTORE, 0);
При этом команда перемещения отрабатывает штатно:
SendMessage(FormToHWND(Self), WM_SYSCOMMAND, $F012, 0);
P.S. Рекомендую Position всегда ставить poScreenCenter. Так как при poDesktopCenter и наличии нескольких мониторов форма появляется между экранами, а не в центе одного из них. Я это сам обнаружил только, когда подключил себе второй монитор.

Да. Окно на FireMonkey не реагирует на это сообщение. Странно, я точно помню что делал уже такое на FireMonkey и оно работало.
Правда было это давно, попробую еще поковыряться, может получится.

Martifan · 3 августа, 2023

FireMonkey - это фреймворк разработки кросс-платформенных приложений на Delphi и C++Builder. В отличие от VCL (Visual Component Library), который тесно интегрирован с WinAPI, FireMonkey разработан для работы с различными платформами, и поэтому он не всегда корректно обрабатывает некоторые функции WinAPI.

WM_SYSCOMMAND - это сообщение WinAPI, которое посылается при выборе команды из системного меню окна. SC_CLOSE, SC_MINIMIZE, SC_MAXIMIZE и SC_RESTORE - это параметры, которые соответствуют командам закрытия, минимизации, максимизации и восстановления окна.

Но поскольку FireMonkey обеспечивает кросс-платформенность и не привязан к WinAPI, он может не корректно обрабатывать такие сообщения. Поэтому, когда вы отправляете эти команды с помощью SendMessage, они могут не вызывать ожидаемого поведения.

По этой причине, для работы с окнами в FireMonkey, лучше использовать встроенные функции и методы фреймворка. Например, для закрытия формы вы можете использовать метод Close, для минимизации и максимизации - свойства WindowState.

Если вам необходимо управлять окном на более низком уровне, возможно, вам придется обратиться к платформо-зависимому коду, используя условные директивы компиляции ({$IFDEF}), чтобы разделить код Windows и код для других платформ. Однако в большинстве случаев этого следует избегать, чтобы сохранить кросс-платформенность вашего приложения.

OnePeople · 3 августа, 2023

 ShowWindow(ApplicationHWND, SW_MINIMIZE);

procedure TForm1.Maximize;
var
   r : TRect;
begin
  r := TRect.Create(0,0,0,0);
  FS := not FS;
  if FS then
    begin
      StandartRect := Form1.Bounds;
      SystemParametersInfo
          (SPI_GETWORKAREA, 0, @r,0) ;
      SetBounds
       (r.Left + 50, r.Top + 50, r.Right-r.Left - 100, r.Bottom-r.Top - 100) ;
      imgalWindowSize.Visible := false;
      r1.YRadius := 0;
      r1.XRadius := 0;
      r3.YRadius := 0;
      r3.XRadius := 0;
      r4.YRadius := 0;
      r4.XRadius := 0;
    end else
      begin
        r:= StandartRect;
        SetBounds
         (r.Left - 50, r.Top - 50, r.Right-r.Left + 100, r.Bottom-r.Top + 100) ;
        imgalWindowSize.Visible := true;
        r1.YRadius := 5;
        r1.XRadius := 5;
        r3.YRadius := 5;
        r3.XRadius := 5;
        r4.YRadius := 5;
        r4.XRadius := 5;
      end;

 TAnimator.AnimateInt(Form1, 'ClientHeight', r.Height, 0.35, TAnimationType.Out, TInterpolationType.Quartic);
 TAnimator.AnimateInt(Form1, 'ClientWidth', r.Width, 0.35, TAnimationType.Out, TInterpolationType.Quartic);
 TAnimator.AnimateInt(Form1, 'Left', r.Left, 0.35, TAnimationType.Out, TInterpolationType.Quartic);
 TAnimator.AnimateInt(Form1, 'Top', r.Top, 0.35, TAnimationType.Out, TInterpolationType.Quartic);
end;

function TForm1.GetWindowColor: TAlphaColor;
var
Reg:TRegistry;
value: TAlphaColor;
begin
  try
    Reg:=TRegistry.Create;
    try
      reg.RootKey :=  HKEY_CURRENT_USER;
      reg.openKey('SOFTWARE\Microsoft\Windows\DWM',true);
      value := reg.ReadInteger('ColorizationColor');
    finally
      Reg.CloseKey;
      Reg.Free;
    end;
    TAlphaColorRec(Value).A := 255;
    Result := value;
  except
    Result := $FFFFB0B0;
  end;
end;

Tumaso · 4 августа, 2023

@Martifan может хватить постить ответы, сгенерированные чатгпт?

Dmitry_4501 · 4 августа, 2023

В 03.08.2023 в 02:41, Aptyp сказал:
@Dmitry_4501 Спасибо, очень классный пример. Те пункты, которые не получились – это уже не столь важно.

Но есть одна проблема, то ли я дурак, то ли лыжи не едут, но FireMonkey вообще никак не реагирует на следующие команды:
SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_CLOSE, 0);

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_MINIMIZE, 0);

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_MAXIMIZE, 0);

SendMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_RESTORE, 0);
При этом команда перемещения отрабатывает штатно:
SendMessage(FormToHWND(Self), WM_SYSCOMMAND, $F012, 0);
P.S. Рекомендую Position всегда ставить poScreenCenter. Так как при poDesktopCenter и наличии нескольких мониторов форма появляется между экранами, а не в центе одного из них. Я это сам обнаружил только, когда подключил себе второй монитор.

Кажется я понял в чем причина.

Попробуйте заменить SendMessage на PostMessage, у меня после этого окно развернулось на весь экран.

Martifan · 5 августа, 2023

21 час назад, Tumaso сказал:

@Martifan может хватить постить ответы, сгенерированные чатгпт?

@Tumaso Собственно чем вас не устраивают ответы чат-бота? Или что-то ошибочно? в отличии от вас, я пытаюсь помочь человеку, если вы тоже можете сгенерировать ответ, почему бы вам этого не сделать? ведь для того и форум, чтобы помочь

Изменено 5 августа, 2023 пользователем Martifan

Tumaso · 6 августа, 2023

Кому нужны ответы, сгенерированные чатгпт, спрашивают их напрямую у чатгпт.

При этом эти ответы имеют очень низкое качество и им не место на этом форуме. Далеко за примером ходить не буду и разберу твой последний опус.

В 03.08.2023 в 21:17, Martifan сказал:

FireMonkey - это фреймворк разработки кросс-платформенных приложений на Delphi и C++Builder.

Забавное вступление для ответа на форуме, посвященному именно фаерманки

В 03.08.2023 в 21:17, Martifan сказал:

В отличие от VCL (Visual Component Library), который тесно интегрирован с WinAPI, FireMonkey разработан для работы с различными платформами

см. выше

В 03.08.2023 в 21:17, Martifan сказал:

и поэтому он не всегда корректно обрабатывает некоторые функции WinAPI.

Конкретные примеры некорректной обработки?

В 03.08.2023 в 21:17, Martifan сказал:

WM_SYSCOMMAND - это сообщение WinAPI, которое посылается при выборе команды из системного меню окна. SC_CLOSE, SC_MINIMIZE, SC_MAXIMIZE и SC_RESTORE - это параметры, которые соответствуют командам закрытия, минимизации, максимизации и восстановления окна.

Для чего этот абзац? Тогда уж предлагаю начать с описания системы сообщений в целом

В 03.08.2023 в 21:17, Martifan сказал:

Но поскольку FireMonkey обеспечивает кросс-платформенность и не привязан к WinAPI

Реализация фаерманки для платформы Windows использует WinAPI

В 03.08.2023 в 21:17, Martifan сказал:

он может не корректно обрабатывать такие сообщения.

и снова - конкретные примеры некорректной обработки именно из за фаерманки?

В 03.08.2023 в 21:17, Martifan сказал:

Поэтому, когда вы отправляете эти команды с помощью SendMessage, они могут не вызывать ожидаемого поведения.

Отправка сообщений в целом не гарантирует на 100% их доставку получателю, хоть на FMX, хоть на VCL, хоть на Qt.

В 03.08.2023 в 21:17, Martifan сказал:

По этой причине, для работы с окнами в FireMonkey, лучше использовать встроенные функции и методы фреймворка. Например, для закрытия формы вы можете использовать метод Close, для минимизации и максимизации - свойства WindowState.

Ничто не мешает использовать сообщения, хотя использовать метод Close конечно понятнее и удобнее.

В 03.08.2023 в 21:17, Martifan сказал:

Если вам необходимо управлять окном на более низком уровне, возможно, вам придется обратиться к платформо-зависимому коду, используя условные директивы компиляции ({$IFDEF}), чтобы разделить код Windows и код для других платформ.

Основы кроссплатформенной разработки

В 03.08.2023 в 21:17, Martifan сказал:

Однако в большинстве случаев этого следует избегать, чтобы сохранить кросс-платформенность вашего приложения.

Основы кроссплатформенной разработки

Итого - ценность поста = 0

Martifan · 6 августа, 2023

@Tumaso:))))))))))))))

начнем с того что не тебе решать каким ответом тут место
не все такие "умные" как ты

я еще раз задам вопрос для тех кто в танке в чем ошибка? то что сгенерировал чат бот?

еще раз повторюсь я стараюсь помочь человека отличие от тебя, неужели своё время не жалко сидеть и строчить всякую ерунду?

можешь помочь человеку помоги, а так никому тут не интересует твой мнении особенно про чат бот.

так что успокойся и не пиши не по тему больше научись ценить свое и чужого времени, в жизни пригодится:)

Tumaso · 6 августа, 2023

2 часа назад, Martifan сказал:

я стараюсь помочь

Так чем ты помог, флудераст? вот в чем вопрос)))

Martifan · 6 августа, 2023

11 часов назад, Tumaso сказал:

Так чем ты помог, флудераст? вот в чем вопрос)))

таких же долбаебов как ты появляется офтопики не принимай как оскравление просто это твоя судьба и не пиши больше хватит офтопить пост

Tumaso · 6 августа, 2023

Aptyp · 6 августа, 2023

@Tumaso @Martifan прошу перестать мусорить в теме. Хотя я вынужден согласиться с @Tumaso , так как изначальное сообщение от @Martifan действительно не несёт никакой полезной информации в данной теме, так ещё и отчасти содержит неверную информацию.

@Dmitry_4501 дабы нормально работала минимизация пришлось дописать ещё

Form.Visible := False;

Иначе форма сворачивается не на панель задач, а в левый угол подобно MDI окну.

В итоге для FireMonkey вышел такой код:

procedure TMainForm.bCloseClick(Sender: TObject);
begin
  PostMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_CLOSE, 0);
end;

procedure TMainForm.bWindowStateClick(Sender: TObject);
begin
  if WindowState = TWindowState.wsNormal then
    PostMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_MAXIMIZE, 0)
  else
    PostMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_RESTORE, 0);
end;

procedure TMainForm.bMinimizeClick(Sender: TObject);
begin
  PostMessage(FormToHWND(Self), WM_SYSCOMMAND, SC_MINIMIZE, 0);
  Visible := False;
end;

Aptyp · 6 августа, 2023

А теперь что касается изначального вопроса: к сожалению мне не удалось нормально рисовать на неклиентской части формы в FireMoneky. Поэтому я убираю клиентскую часть выставляя в стилях ширину боковых границ и высоту нижней границы и заголовка равные 0. То есть BorderStyle остаётся Sizeable, но границ просто не видно. Делаю свои кнопки формы (закрыть, развернуть...), похожие по стилю в Windows с обработчиками, что выше в сообщении, а изменение размеров окна беру из примера @Dmitry_4501, в итоге выходит такой код:

type PWMNCHitTest = ^TWMNCHitTest;

if uMsg = WM_NCHITTEST then
  begin
    const EdgeWidth = 6;
    var NCHitTest: PWMNCHitTest := PWMNCHitTest(lParam);
    var xPos := LOWORD(lParam);
    var yPos := HIWORD(lParam);
    var Pos: TPointF := Self.ScreenToClient(TPointF.Create(xPos, yPos));

    Result := 0;
    if Pos.X <= EdgeWidth then
      begin
        if Pos.Y <= EdgeWidth then
          Result := HTTOPLEFT
        else if Pos.Y >= Self.ClientHeight - EdgeWidth then
          Result := HTBOTTOMLEFT
        else
          Result := HTLEFT;
      end
    else if Pos.X >= Self.ClientWidth - EdgeWidth then
      begin
        if Pos.Y <= EdgeWidth then
          Result := HTTOPRIGHT
        else if Pos.Y >= Self.ClientHeight - EdgeWidth then
          Result := HTBOTTOMRIGHT
        else
          Result := HTRIGHT;
      end
    else if Pos.Y <= EdgeWidth then
      Result := HTTOP
    else if Pos.Y >= Self.ClientHeight - EdgeWidth then
      Result := HTBOTTOM;

    Prevent := Result <> 0;
  end;

Ну и стоит учесть, что в Firemonkey так просто не обработаешь сообщения окна. Надо делать некий костыль для формы в виде кода:

type
  TMainForm = class(TForm)
    private
      FOldWndProc: LONG_PTR;
    protected
      procedure CreateHandle; override;
      procedure DestroyHandle; override;
  end;

...

procedure TMainForm.CreateHandle;
  function WindowProc(hwnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
  var
    frm: TCommonCustomForm;
    Prevent: Boolean;
  begin
    frm := FMX.Platform.Win.FindWindow(hwnd);
    Assert(frm.InheritsFrom(TForm));
    Prevent := False;

    if uMsg = WM_NCHITTEST then
      begin
      	...
      end;

    if not Prevent then
      Result := CallWindowProc(Ptr(TForm(frm).FOldWndProc), hwnd, uMsg, WParam, lParam);
  end;
begin
  inherited CreateHandle;
  FOldWndProc := GetWindowLongPtr(FormToHWND(Self), GWL_WNDPROC);
  SetWindowLongPtr(FormToHWND(Self), GWL_WNDPROC, NativeInt(@WindowProc));
end;

procedure TMainForm.DestroyHandle;
begin
  Assert( FormToHWND(Self) <> 0 );
  SetWindowLongPtr(FormToHWND(Self), GWL_WNDPROC, FOldWndProc);
  inherited DestroyHandle;
end;

Конечно же всё это только для Windows платформы.

Изменено 7 августа, 2023 пользователем Aptyp

Dmitry_4501 · 7 августа, 2023

8 часов назад, Aptyp сказал:

А теперь что касается изначального вопроса: к сожалению мне не удалось нормально рисовать на неклиентской части формы в FireMoneky. Поэтому я убираю клиентскую часть выставляя в стилях ширину боковых границ и высоту нижней границы и заголовка равные 0. То есть BorderStyle остаётся Sizeable, но границ просто не видно. Делаю свои кнопки формы (закрыть, развернуть...), похожие по стилю в Windows с обработчиками, что выше в сообщении, а изменение размеров окна беру из примера @Dmitry_4501, в итоге выходит такой код:

type PWMNCHitTest = ^TWMNCHitTest;

if uMsg = WM_NCHITTEST then
  begin
    const EdgeWidth = 6;
    var NCHitTest: PWMNCHitTest := PWMNCHitTest(lParam);
    var xPos := LOWORD(lParam);
    var yPos := HIWORD(lParam);
    var Pos: TPointF := Self.ScreenToClient(TPointF.Create(xPos, yPos));

    Result := 0;
    if Pos.X <= EdgeWidth then
      begin
        if Pos.Y <= EdgeWidth then
          Result := HTTOPLEFT
        else if Pos.Y >= Self.ClientHeight - EdgeWidth then
          Result := HTBOTTOMLEFT
        else
          Result := HTLEFT;
      end
    else if Pos.X >= Self.ClientWidth - EdgeWidth then
      begin
        if Pos.Y <= EdgeWidth then
          Result := HTTOPRIGHT
        else if Pos.Y >= Self.ClientHeight - EdgeWidth then
          Result := HTBOTTOMRIGHT
        else
          Result := HTRIGHT;
      end
    else if Pos.Y <= EdgeWidth then
      Result := HTTOP
    else if Pos.Y >= Self.ClientHeight - EdgeWidth then
      Result := HTBOTTOM;

    Prevent := Result <> 0;
  end;

Ну и стоит учесть, что в Firemonkey так просто не обработаешь сообщения окна. Надо делать некий костыль для формы в виде кода:

type
  TMainForm = class(TForm)
    private
      FOldWndProc: LONG_PTR;
    protected
      procedure CreateHandle; override;
      procedure DestroyHandle; override;
  end;

...

procedure TMainForm.CreateHandle;
  function WindowProc(hwnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
  var
    frm: TCommonCustomForm;
    Prevent: Boolean;
  begin
    frm := FMX.Platform.Win.FindWindow(hwnd);
    Assert(frm.InheritsFrom(TForm));
    Prevent := False;

    if uMsg = WM_NCHITTEST then
      begin
      	...
      end;

    if not Prevent then
      Result := CallWindowProc(Ptr(TForm(frm).FOldWndProc), hwnd, uMsg, WParam, lParam);
  end;
begin
  inherited CreateHandle;
  FOldWndProc := GetWindowLongPtr(FormToHWND(Self), GWL_WNDPROC);
  SetWindowLongPtr(FormToHWND(Self), GWL_WNDPROC, NativeInt(@WindowProc));
end;

procedure TMainForm.DestroyHandle;
begin
  Assert( FormToHWND(Self) <> 0 );
  SetWindowLongPtr(FormToHWND(Self), GWL_WNDPROC, FOldWndProc);
  inherited DestroyHandle;
end;

Конечно же всё это только для Windows платформы.

Оконные сообщения в FMX можно обрабатывать так же как и в VCL.
Достаточно в вашу WindowProc добавить это:

var Message: TMessage; 

Message.Msg := uMsg;
Message.WParam := wParam;
Message.LParam := lParam;
Message.Result := 0;

frm.Dispatch(Message);

Тогда потом можно будет смело написать что-то вроде

procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;

И оно будет работать.

Изменено 7 августа, 2023 пользователем Dmitry_4501

Aptyp · 11 августа, 2023

@Dmitry_4501 в том то и дело, что не будет. Я прямо в моей функции WindowProc писал условие и рисовал. Причём обрабатывал не только WM_NCPAINT, но и WM_PAINT и многое другое, что хоть как-то может быть с этим связано. В FireMonkey это стабильно не работает. Иногда рисует, иногда нет. По крайней мере в моём случае, когда форма Acrylic и к ней применяется стиль.

    if uMsg = WM_NCPAINT then
      begin
      	...
      end;

Dmitry_4501 · 12 августа, 2023

13 часов назад, Aptyp сказал:
@Dmitry_4501 в том то и дело, что не будет. Я прямо в моей функции WindowProc писал условие и рисовал. Причём обрабатывал не только WM_NCPAINT, но и WM_PAINT и многое другое, что хоть как-то может быть с этим связано. В FireMonkey это стабильно не работает. Иногда рисует, иногда нет. По крайней мере в моём случае, когда форма Acrylic и к ней применяется стиль.
    if uMsg = WM_NCPAINT then
      begin
      	...
      end;

Можно увидеть вашу реализацию безрамочной формы и вашей WindowProc?

Войти

Рисование на неклиентской часть окна

Вопрос

Ссылка на комментарий

24 ответа на этот вопрос

Рекомендуемые сообщения

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Ссылка на комментарий

Присоединяйтесь к обсуждению

Похожий контент

Последние посетители 0 пользователей онлайн