VCL Form and Frame Scale Fix

В продолжение развитии темы базовой формы и фреймы. Хорошая новость: я решил добавить поддержку Delphi 7, которая оказалась довольно живучей. Ещё я сделал разделение пакета на два: DesignTime only (пакет с визардами) и RunTime only (пакет с модулем BaseForms). Плюс я хочу поделиться решением одной насущной проблемы…

Многие Delphi-программисты знают, что в VCL происходит некорректное масштабирование форм. Само масштабирование применяется в случае, когда текущее логическое разрешение экрана (значение Screen.PixelsPerInch) не совпадает с тем, при котором разрабатывалась форма в дизайнере (значение PixelsPerInch, сохранённое в DFM-файле). Некорректность заключается в том, что в некоторых случаях масштабирование не применяется к размеру самой формы, но применяется ко всем дочерним контролам. Также не масштабируются констрейнты формы, что приводит к ещё более некрасивым результатам – сначала форма масштабируется, а потом её размер ограничивается старыми констрейнтами.

А ещё VCL не масштабирует фреймы. Т.е. если фрейму создать в Run-Time вручную, а после этого встроить в форму, то фрейма останется неотмасштабированной.

Для наглядности приведу картинки.

Так форма выглядит без масштабирования (ppi = 96) в классической теме оформления (слева) и  Aero (справа):

А так уже с масштабированием (ppi = 120):

Тут видно, что внешний размер формы не изменился, хотя сами контролы отмасштабировались. А ещё на картинке справа уменьшился размер клиентской области.

Теперь я укажу у формы свойство BorderStyle = bsSingle, это неявным образом заставит VCL сохранить свойства ClientWidth и ClientHeight в DFM-файл формы. Вот что получилось:

Похоже, что в этом случае масштабирование прошло корректно. А теперь у формы указываю констрейнты, получаем такую картинку:

Всё отмасштабировалось, но потом размер формы сбросился до констрейнтов, которые не отмасштабировались.

Ну и на последок я вернул форме стиль границы и сбросил якоря для всех контролов в значения по умолчанию ([akLeft, akTop]), получилось так:

На картинках показано приложение, собранное в Delphi 7. В Delphi 2010 проблемы масштабирования проявляются реже, но всё же проявляются. Например, достаточно выставить свойство AutoScroll = True, и получим поведение масштабирования как на второй картинке.

Есть ещё одна проблема: VCL не масштабирует фреймы, созданные в Run-Time. Вот простой пример:

procedure TForm1.Button1Click(Sender: TObject);
var
  Form: TForm;
  Frame: TFrame2;
begin
  Form := TForm.Create(Self);
  Frame := TFrame2.Create(Form);
  Form.ClientHeight := Frame.Height;
  Form.ClientWidth := Frame.Width;
  Frame.Align := alClient;
  Frame.Parent := Form;
  Form.Show;
end;

По клику на кнопке получим форму с неотмасштабированной фреймой. Это воспроизводится и в Delphi XE2 (в более поздних пока не проверял).

Фиксим масштабирование форм

Я решил эту проблему в несколько этапов.

1. Необходимо во время дизайна формы принудительно сохранять значения ClientWidth и ClientHeight.
2. Необходимо отключить масштабирование на уровне VCL.
3. Необходимо самостоятельно выполнить масштабирование.

Первое решается довольно просто:

..
  private
    procedure WriteClientHeight(Writer: TWriter);
    procedure WriteClientWidth(Writer: TWriter);
  protected
    procedure DefineProperties(Filer: TFiler); override;
..
procedure TBaseForm.WriteClientHeight(Writer: TWriter);
begin
  Writer.WriteInteger(ClientHeight);
end;

procedure TBaseForm.WriteClientWidth(Writer: TWriter);
begin
  Writer.WriteInteger(ClientWidth);
end;

procedure TBaseForm.DefineProperties(Filer: TFiler);
  function NeedWriteClientSize: Boolean;
  begin
    //Result := Scaled and not IsClientSizeStored
    // IsClientSizeStored = not IsFormSizeStored
    // IsFormSizeStored = AutoScroll or (HorzScrollBar.Range <> 0) or (VertScrollBar.Range <> 0)
    Result := Scaled and (AutoScroll or (HorzScrollBar.Range <> 0) or (VertScrollBar.Range <> 0));
  end;
begin
  inherited DefineProperties(Filer);

  // ClientHeight и ClientWidth сохраняются не всегда, а вместо этого сохраняются внешние размеры формы.
  // Это не совсем правильно, т.к. масштабировать необходимо именно клиентскую область. Функция NeedWriteClientSize
  // определяет, нужно ли принудительно сохранять размер клиентской области.
  Filer.DefineProperty('ClientHeight', nil, WriteClientHeight, NeedWriteClientSize);
  Filer.DefineProperty('ClientWidth', nil, WriteClientWidth, NeedWriteClientSize);
end;

Второе решается сложнее: масштабирование VCL делает в методе TCustomForm.ReadState сразу после считывания DFM:

...
    inherited ReadState(Reader);
    if (FPixelsPerInch <> 0) and (FTextHeight > 0) then
    begin
      // проверка, изменилось ли значение PixelsPerInch и 
      // само масштабирование
    end;
...

В общем я решил сбросить значение приватного поля FTextHeight в 0. Чтобы это можно было сделать, необходимо вклиниться в код между строками 2 и 3. Для этого я объявил фэйковое свойство под названием ScaleFix, которое считывается самым последним у формы, выглядит это примерно так:

...
  private
    FPixelsPerInch: Integer;
    procedure WriteScaleFix(Writer: TWriter);
    procedure ReadScaleFix(Reader: TReader);
...
procedure TBaseForm.WriteScaleFix(Writer: TWriter);
begin
  // просто сохраняем флаг в DFM-файл, чтобы при его чтении можно было вклиниться в процесс метода ReadState
  Writer.WriteBoolean(True);
end;

procedure TBaseForm.ReadScaleFix(Reader: TReader);
begin
  if not Reader.ReadBoolean then
    Exit;

  // запоминаем прочитанное ранее свойство PixelsPerInch
  FPixelsPerInch := THackCustomForm(Self).FPixelsPerInch;
  // и устанавливаем текущее
  THackCustomForm(Self).FPixelsPerInch := Screen.PixelsPerInch;

  // сбрасываем свойство FTextHeight для отключения масштабирования на уровне VCL
  THackCustomForm(Self).FTextHeight := 0;
end;

procedure TBaseForm.DefineProperties(Filer: TFiler);
...
  Filer.DefineProperty('ScaleFix', ReadScaleFix, WriteScaleFix, Scaled);
end;

Ну и наконец, третье: масштабирование своей процедурой. Делается в методе Loaded.

...
  protected
    procedure Loaded; override;
...
procedure TBaseForm.Loaded;
begin
  if (FPixelsPerInch > 0) and (FPixelsPerInch <> Screen.PixelsPerInch) then
    ScaleControl(Self, Screen.PixelsPerInch, FPixelsPerInch);

  inherited Loaded;
end;

Самое интересное в процедуре ScaleControl (её код – ниже), к сожалению без хака там не обошлось, причём хак жёстко привязан к версии Delphi, т.к. необходимо получать доступ к приватным полям компонентов. Если Вы сравните мою процедуру с тем, как масштабирует VCL, вы увидите, что я не обрабатываю ScalingFlags. Дело в том, что у меня масштабирование вызывается всего один раз после полной загрузки формы в методе Loaded, и этого достаточно, т.к. масштабирование нужно применять для всех контролов. В VCL же масштабирование применяется в методе ReadState, который вызывается несколько раз – для каждого класса в иерархии, у которых есть DFM-ресурс. А такое встречается, если используется визуальное наследование. Поэтому VCL необходимо знать, масштабировался контрол, или нет, для чего и используется это свойство ScalingFlags. Этот “финт ушами” VCL использует для случая, когда разные формы в цепочке визуального наследования разрабатываются при разных значениях свойства PixelsPerInch.

Вот код самой процедуры (описание типов THackXXX можно найти в исходнике):

procedure ScaleControl(Control: TControl; MX, DX, MY, DY, MF, DF: Integer);
  procedure ScaleControlConstraints(Control: TControl);
  begin
    with THackSizeConstraints(Control.Constraints) do
    begin
      FMaxHeight := MulDiv(FMaxHeight, MY, DY);
      FMaxWidth := MulDiv(FMaxWidth, MX, DX);
      FMinHeight := MulDiv(FMinHeight, MY, DY);
      FMinWidth := MulDiv(FMinWidth, MX, DX);
    end;
    //TFriendlySizeConstraints(Control.Constraints).Change;
  end;

  {$ifdef Controls.TMargins}
  procedure ScaleControlMargins(Control: TControl);
  begin
    with THackMargins(Control.Margins) do
    begin
      FLeft := MulDiv(FLeft, MX, DX);
      FTop := MulDiv(FTop, MY, DY);
      FRight := MulDiv(FRight, MX, DX);
      FBottom := MulDiv(FBottom, MY, DY);
    end;
    //TFriendlyMargins(Control.Margins).Change;
  end;
  {$endif}

  procedure ScaleControl(Control: TControl);
  var
    L, T, W, H: Integer;
  begin
    with Control do
    begin
      // scale Left
      L := MulDiv(Left, MX, DX);
      // scale Top
      T := MulDiv(Top, MY, DY);
      // scale Width
      if not (csFixedWidth in ControlStyle) then
        W := MulDiv(Left + Width, MX, DX) - L
      else
        W := Width;
      // scale Hight
      if not (csFixedHeight in ControlStyle) then
        H := MulDiv(Top + Height, MY, DY) - T
      else
        H := Height;
    end;

    ScaleControlConstraints(Control);

    {$ifdef Controls.TMargins}
    ScaleControlMargins(Control);
    {$endif}

    {$ifdef bf_tb2k}
    // scale TTBToolWindow
    if Control is TTBToolWindow then
      with TTBToolWindow(Control) do
      begin
        MaxClientHeight := MulDiv(MaxClientHeight, MY, DY);
        MaxClientWidth := MulDiv(MaxClientWidth, MX, DX);
        MinClientHeight := MulDiv(MinClientHeight, MY, DY);
        MinClientWidth := MulDiv(MinClientWidth, MX, DX);
      end;
    {$endif}

    // apply new bounds (with check constraints and margins)
    Control.SetBounds(L, T, W, H);

    with THackControl(Control), TFriendlyControl(Control) do
    begin
      // scale OriginalParentSize
      FOriginalParentSize.X := MulDiv(FOriginalParentSize.X, MX, DX);
      FOriginalParentSize.Y := MulDiv(FOriginalParentSize.Y, MY, DY);

      // scale Font.Size
      if not ParentFont and (MF <> DF) then
        Font.Size := MulDiv(Font.Size, MF, DF);
    end;
  end;

  procedure ScaleWinControlDesignSize(WinControl: TWinControl);
  begin
    with TFriendlyWinControl(WinControl) do
    begin
      FDesignSize.X := MulDiv(FDesignSize.X, MX, DX);
      FDesignSize.Y := MulDiv(FDesignSize.Y, MY, DY);
    end;
  end;

  {$ifdef Controls.TPadding}
  procedure ScaleWinControlPadding(WinControl: TWinControl);
  begin
    with THackPadding(WinControl.Padding) do
    begin
      FLeft := MulDiv(FLeft, MX, DX);
      FTop := MulDiv(FTop, MY, DY);
      FRight := MulDiv(FRight, MX, DX);
      FBottom := MulDiv(FBottom, MY, DY);
    end;
    TFriendlyPadding(WinControl.Padding).Change;
  end;
  {$endif}

  procedure ScaleWinControl(WinControl: TWinControl);
  begin
    ScaleControl(WinControl);

    ScaleWinControlDesignSize(WinControl);

    {$ifdef Controls.TPadding}
    ScaleWinControlPadding(WinControl);
    {$endif}
  end;

  procedure ScaleScrollBars(Control: TScrollingWinControl);
  begin
    with TFriendlyScrollingWinControl(Control) do
    begin
      if not AutoScroll then
      begin
        with HorzScrollBar do
        begin
          Position := 0;
          Range := MulDiv(Range, MX, DX);
        end;
        with VertScrollBar do
        begin
          Position := 0;
          Range := MulDiv(Range, MY, DY);
        end;
      end;
    end;
  end;

  procedure ScaleScrollingWinControl(ScrollingWinControl: TScrollingWinControl);
  begin
    ScaleScrollBars(ScrollingWinControl);
    ScaleWinControl(ScrollingWinControl);
  end;

  procedure ScaleCustomFormConstraints(CustomForm: TCustomForm; cdx, cdy: Integer);
    procedure ScaleValue(var Value: TConstraintSize; M, D, s: Integer);
    var
      tmp: Integer;
    begin
      if Value > 0 then
      begin
        tmp := MulDiv(Value - s, M, D) + s;
        if tmp < 0
          then Value := 0
          else Value := tmp;
      end;
    end;
  begin
    // при масштабировании констрейнтов формы, надо учитывать
    // разницу между внешними размерами и размерами клиентской области
    with THackSizeConstraints(CustomForm.Constraints) do
    begin
      ScaleValue(FMaxWidth, MX, DX, cdx);
      ScaleValue(FMinWidth, MX, DX, cdx);
      ScaleValue(FMaxHeight, MY, DY, cdy);
      ScaleValue(FMinHeight, MY, DY, cdy);
    end;
    //TFriendlySizeConstraints(Constraints).Change;
  end;

  procedure ScaleCustomForm(CustomForm: TCustomForm);
  var
    W, H: Integer;
    cdx, cdy: Integer;
  begin
    with CustomForm do
    begin
      cdx := Width - ClientWidth;
      cdy := Height - ClientHeight;

      if MF <> DF then
        Font.Height := MulDiv(Font.Height, MF, DF);

      W := MulDiv(ClientWidth, MX, DX) + cdx;
      H := MulDiv(ClientHeight, MY, DY) + cdy;
    end;

    ScaleWinControlDesignSize(CustomForm);

    ScaleScrollBars(CustomForm);

    ScaleCustomFormConstraints(CustomForm, cdx, cdy);

    // При уменьшении размера иногда (пока не разбирался почему) новые размеры не применяются
    // Наращивание ширины и высоты на 1 пиксель помогает обойти такую проблему
    if DX > MX then
      inc(W);
    if DY > MY then
      inc(H);

    // apply new bounds (with check constraints and margins)
    with CustomForm do
      SetBounds(Left, Top, W, H);
  end;

  procedure ScaleAndAlignWinControl(WinControl: TWinControl);
  var
    SavedAnchors: array of TAnchors;
    i: Integer;
  begin
    with WinControl do
    begin
      // disable anchors of child controls:
      SetLength(SavedAnchors, ControlCount);
      for i := 0 to ControlCount - 1 do
      begin
        SavedAnchors[i] := Controls[i].Anchors;
        Controls[i].Anchors := [akLeft, akTop];
      end;

      DisableAlign;
      try
        // scale itself:
        if WinControl is TCustomForm then
          ScaleCustomForm(TCustomForm(WinControl))
        else if WinControl is TScrollingWinControl then
          ScaleScrollingWinControl(TScrollingWinControl(WinControl))
        else
          ScaleWinControl(WinControl);

        // scale child controls:
        for i := 0 to ControlCount - 1 do
          BaseForms.ScaleControl(Controls[i], MX, DX, MY, DY, MF, DF);
      finally
        EnableAlign;

        // enable anchors of child controls:
        for i := 0 to ControlCount - 1 do
          Controls[i].Anchors := SavedAnchors[i];
      end;
    end;
  end;
begin
  if Control is TWinControl then
    ScaleAndAlignWinControl(TWinControl(Control))
  else
    ScaleControl(Control);
end;

Приведённое мною решение проблемы масштабирования вполне работоспособное. Единственное требование, которое я к нему предъявляю – разработка всех форм в одном разрешении, и то, если у Вас используется визуальное наследование.

Фиксим масштабирование фрейм

С фреймой проще: нам достаточно сохранять/считывать свойство PixelsPerInch и выполнять масштабирование в том случае, если фрейма создана без родителя.

...
  private
    FPixelsPerInch: Integer;
    procedure WritePixelsPerInch(Writer: TWriter);
    procedure ReadPixelsPerInch(Reader: TReader);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    procedure Loaded; override;
...
procedure TBaseFrame.WritePixelsPerInch(Writer: TWriter);
begin
  Writer.WriteInteger(Screen.PixelsPerInch);
end;

procedure TBaseFrame.ReadPixelsPerInch(Reader: TReader);
begin
  FPixelsPerInch := Reader.ReadInteger;
end;

procedure TBaseFrame.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);

  // сохранять свойство PixelsPerInch нужно только при дизайне самой фреймы. Если фрейма встроена во что-то, то
  // тогда свойство сохранять не нужно
  Filer.DefineProperty('PixelsPerInch', ReadPixelsPerInch, WritePixelsPerInch, not Assigned(Filer.Ancestor));
end;

procedure TBaseFrame.Loaded;
begin
  // масштабируем только в том случае, если фрейма создаётся в Run-Time вручную (т.е. Parent = nil),
  // либо в дизайнере
  if (FPixelsPerInch > 0) and (FPixelsPerInch <> Screen.PixelsPerInch) and
    (not Assigned(Parent) or (csDesigning in ComponentState))
  then
    ScaleControl(Self, Screen.PixelsPerInch, FPixelsPerInch);

  inherited Loaded;
end;

Скачать

Исходники доступны на этой странице. Ссылка для быстрого скачивания.

UPD 16.05.2013 – небольшой рефакторинг + поддержка Delphi XE2