Гость
Форумы / Delphi [игнор отключен] [закрыт для гостей] / Масштабируемость контролов при установке системного шрифта / 6 сообщений из 6, страница 1 из 1
24.11.2021, 13:47
    #40114509
vSerg
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Масштабируемость контролов при установке системного шрифта
На XE2 в приложении была сделана подстановка родного шрифта Tahoma на системный шрифт (по примеру Gunsmoker'а http://www.gunsmoker.ru/2010/11/windows-xp-windows-vista7.html). Все работало замечательно. В дизайнере и runtime все отображалось пропорционально.

Однако при переходе на 10.2 (и 10.3) данный метод перестал работать, т.к. при построении формы был выкинут кусок проверяющий высоту шрифта.
Вот как это выглядело в XE2:

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
procedure TCustomForm.ReadState(Reader: TReader);
var
  NewTextHeight: Integer;
  Scaled: Boolean;
begin
  DisableAlign;
  try
    FClientWidth := 0;
    FClientHeight := 0;
    FTextHeight := 0;
    Scaled := False;
{$IF NOT DEFINED(CLR)}
    if ClassParent = TForm then
      FOldCreateOrder := not ModuleIsCpp;
{$IFEND}
    inherited ReadState(Reader);
    if (FPixelsPerInch <> 0) and (FTextHeight > 0) then
    begin
      if (sfFont in ScalingFlags) and (FPixelsPerInch <> Screen.PixelsPerInch) then
        Font.Height := MulDiv(Font.Height, Screen.PixelsPerInch, FPixelsPerInch);
      FPixelsPerInch := Screen.PixelsPerInch;
      NewTextHeight := GetTextHeight;
      if FTextHeight <> NewTextHeight then
      begin
        Scaled := True;
        ScaleScrollBars(NewTextHeight, FTextHeight);
        ScaleConstraints(NewTextHeight, FTextHeight);
        ScaleControls(NewTextHeight, FTextHeight);
        if sfWidth in ScalingFlags then
          FClientWidth := MulDiv(FClientWidth, NewTextHeight, FTextHeight);
        if sfHeight in ScalingFlags then
          FClientHeight := MulDiv(FClientHeight, NewTextHeight, FTextHeight);
        if sfDesignSize in ScalingFlags then
        begin
          FDesignSize.X := MulDiv(FDesignSize.X, NewTextHeight, FTextHeight);
          FDesignSize.Y := MulDiv(FDesignSize.Y, NewTextHeight, FTextHeight);
        end;
      end;
    end;
    if FClientWidth > 0 then inherited ClientWidth := FClientWidth;
    if FClientHeight > 0 then inherited ClientHeight := FClientHeight;
    ScalingFlags := [];
    if not Scaled then
    begin
      { Forces all ScalingFlags to [] }
      ScaleScrollBars(1, 1);
      ScaleControls(1, 1);
    end;
    Perform(CM_PARENTBIDIMODECHANGED, 0, 0);
  finally
    EnableAlign;
  end;
end;



В десятках так:

Код: pascal
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
procedure TCustomForm.ReadState(Reader: TReader);
begin
{$IF NOT DEFINED(CLR)}
  if ClassParent = TForm then
    FOldCreateOrder := not ModuleIsCpp;
{$ENDIF}
  DisableAlign;
  try
    inherited ReadState(Reader);
  finally
    EnableAlign;
  end;
end;




Результат такой:


Первая картинка - это Tahoma

Вторая картинка - подмена системного шрифта. Сам шрифт у Label и Edit поменялся на Segoe. Размеры поменялись только у Edit, т.к. у него собственная обработка высоты шрифта.

Третья картинка - с вставленным куском кода из XE2. Видно, что отмасштабировались все контролы согласно пропорции шрифтов.
...
Рейтинг: 0 / 0
24.11.2021, 14:03
    #40114516
vSerg
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Масштабируемость контролов при установке системного шрифта
Собственно вопрос - как установить приложению системный шрифт?
...
Рейтинг: 0 / 0
24.11.2021, 15:32
    #40114552
Zelius
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Масштабируемость контролов при установке системного шрифта
vSerg,

возможно пальцем в небо: попробуй убери опцию Enable High-DPI в опциях манифеста проекта
...
Рейтинг: 0 / 0
25.11.2021, 10:42
    #40114766
vSerg
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Масштабируемость контролов при установке системного шрифта
Zelius,

В том то и дело, что DPI тут ни при чем. В коде отсутствует сравнение размеров шрифта среды разработки и системного шрифта при создании формы. Все происходит на одном компьютере со стандартным DPI и в дизайне, и в рантайме.

Пока видится написание хелпера для TCustomForm и переопределение ReadState.

Либо я чего-то упускаю в 10ке.
...
Рейтинг: 0 / 0
25.11.2021, 13:34
    #40114844
_Vasilisk_
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Масштабируемость контролов при установке системного шрифта
vSerg
Пока видится написание хелпера для TCustomForm и переопределение ReadState.
Хелперы не умеют переопределять методы
...
Рейтинг: 0 / 0
26.11.2021, 10:06
    #40115142
vSerg
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Масштабируемость контролов при установке системного шрифта
_Vasilisk_
Хелперы не умеют переопределять методы


Согласен, но можно подменить вызов метода на свой.

Тут есть пример как это сделать.
...
Рейтинг: 0 / 0
Форумы / Delphi [игнор отключен] [закрыт для гостей] / Масштабируемость контролов при установке системного шрифта / 6 сообщений из 6, страница 1 из 1
Целевая тема:
Создать новую тему:
Автор:
Найденые пользователи ...
Разблокировать пользователей ...
Читали форум (0):
Пользователи онлайн (0):
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]