Добро пожаловать в форум, Guest  >>   Войти | Регистрация | Поиск | Правила | В избранное | Подписаться
Все форумы / Delphi Новый топик    Ответить
 Масштабируемость контролов при установке системного шрифта  [new]
vSerg
Member

Откуда: Санкт-Петербург
Сообщений: 36
На XE2 в приложении была сделана подстановка родного шрифта Tahoma на системный шрифт (по примеру Gunsmoker'а [url=]http://www.gunsmoker.ru/2010/11/windows-xp-windows-vista7.html[/url]). Все работало замечательно. В дизайнере и runtime все отображалось пропорционально.

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

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;


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

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. Видно, что отмасштабировались все контролы согласно пропорции шрифтов.

Сообщение было отредактировано: 24 ноя 21, 13:55
24 ноя 21, 13:47    [22400177]     Ответить | Цитировать Сообщить модератору
 Re: Масштабируемость контролов при установке системного шрифта  [new]
vSerg
Member

Откуда: Санкт-Петербург
Сообщений: 36
Собственно вопрос - как установить приложению системный шрифт?

К сообщению приложен файл. Размер - 78Kb
24 ноя 21, 14:03    [22400190]     Ответить | Цитировать Сообщить модератору
 Re: Масштабируемость контролов при установке системного шрифта  [new]
Zelius
Member

Откуда: Россия, Москва
Сообщений: 1592
vSerg,

возможно пальцем в небо: попробуй убери опцию Enable High-DPI в опциях манифеста проекта
24 ноя 21, 15:32    [22400236]     Ответить | Цитировать Сообщить модератору
 Re: Масштабируемость контролов при установке системного шрифта  [new]
vSerg
Member

Откуда: Санкт-Петербург
Сообщений: 36
Zelius,

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

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

Либо я чего-то упускаю в 10ке.

Сообщение было отредактировано: 25 ноя 21, 10:42
25 ноя 21, 10:42    [22400548]     Ответить | Цитировать Сообщить модератору
 Re: Масштабируемость контролов при установке системного шрифта  [new]
_Vasilisk_
Member

Откуда: Украина, Харьков
Сообщений: 13351
vSerg
Пока видится написание хелпера для TCustomForm и переопределение ReadState.
Хелперы не умеют переопределять методы
25 ноя 21, 13:34    [22400677]     Ответить | Цитировать Сообщить модератору
 Re: Масштабируемость контролов при установке системного шрифта  [new]
vSerg
Member

Откуда: Санкт-Петербург
Сообщений: 36
_Vasilisk_
Хелперы не умеют переопределять методы


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

Тут есть пример как это сделать.
26 ноя 21, 10:06    [22401099]     Ответить | Цитировать Сообщить модератору
Все форумы / Delphi Ответить