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

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 пользователей онлайн