Fix RSP-20799

PK.Fix.Scale.ComboBox.pas

(*
 * Fix:
 *   Deal with a problem that ComboBox can not be operated when Scale is
 *   greater than 100%
 *
 * USAGE:
 *   Just add PK.Fix.Scale.ComboBox to the uses section.
 *
 * LICENSE:
 *   Copyright (c) 2018 HOSOKAWA Jun
 *   Released under the MIT license
 *   http://opensource.org/licenses/mit-license.php
 *
 * 2018/05/29 Version 1.0.0
 * Programmed by HOSOKAWA Jun (twitter: @pik)
 *)

unit PK.Fix.Scale.ComboBox;

{$IFNDEF MSWINDOWS}
{$WARNINGS OFF}
interface
implementation
end.
{$ENDIF}

interface

implementation

uses
  System.Classes
  , System.Types
  , System.SysUtils
  , System.Messaging
  , Winapi.Windows
  , FMX.Types
  , FMX.Controls
  , FMX.Forms
  , FMX.ListBox
  , FMX.Pickers.Default
  , FMX.Platform.Win
  ;

type
  TFormDetector = class
  private var
    FScale: Single;
  private
    procedure AfterCreateFormHandler(
      const Sender: TObject;
      const Msg: System.Messaging.TMessage);
    procedure FormShow(Sender: TObject);
    procedure FormHide(Sender: TObject);
    procedure FormAniTimer(Sender: TObject);
  public
    constructor Create; reintroduce;
  end;

  TOpenCustomPopupForm = class(TCustomPopupForm)
  end;

{ TFormDetector }

procedure TFormDetector.AfterCreateFormHandler(
  const Sender: TObject;
  const Msg: System.Messaging.TMessage);
var
  ACF: TAfterCreateFormHandle absolute Msg;
  Form: TCommonCustomForm;
  OpenForm: TOpenCustomPopupForm absolute Form;
var
  Wnd: TWinWindowHandle;
begin
  if not (Msg is TAfterCreateFormHandle) then
    Exit;

  Form := ACF.Value;
  if Form is TCustomPopupForm then
  begin
    Wnd := WindowHandleToPlatform(TCustomPopupForm(Sender).Handle);
    if Wnd = nil then
      Exit;

    if FScale = 0 then
      FScale := Wnd.Scale;

    if FScale = 1 then
      Exit;

    Form.OnShow := FormShow;
    Form.OnHide := FormHide;
    OpenForm.OnAniTimer := FormAniTimer;
  end;
end;

constructor TFormDetector.Create;
begin
  inherited Create;

  TMessageManager.DefaultManager.SubscribeToMessage(
    TAfterCreateFormHandle,
    AfterCreateFormHandler);
end;

procedure TFormDetector.FormAniTimer(Sender: TObject);
var
  Wnd: TWinWindowHandle;
  R: TRect;
begin
  if not (Sender is TCustomPopupForm) then
    Exit;

  Wnd := WindowHandleToPlatform(TCustomPopupForm(Sender).Handle);
  if Wnd = nil then
    Exit;

  R := Wnd.Bounds;

  TThread.ForceQueue(
    TThread.Current,
    procedure
    var
      Child: TFmxObject;
      Control: TControl absolute Child;
      C: TFmxObject;
      ListBox: TListBox;
      Item: TListBoxItem;
      i: Integer;
      FS: Single;
      H: Single;

      function Calc(const iValue: Integer): Integer;
      begin
        Result := Round(iValue * FScale);
      end;

    begin
      Wnd.Form.BeginUpdate;
      try
        Wnd.Form.Top := Trunc(R.Top + 2 * FScale);
        Wnd.Form.Left := Trunc(R.Left + 2 * FScale);

        for Child in Wnd.Form.Children do
          if Child is TControl then
          begin
            Control.Visible := True;

            if Control is TPopup then // = TPopupListPicker
            begin
              H := 0;
              for C in Control.Children do
                if C is TListBox then
                begin
                  ListBox := TListBox(C);
                  ListBox.ItemHeight := ListBox.ItemHeight * FScale;

                  for i := 0 to ListBox.Items.Count - 1 do
                  begin
                    Item := ListBox.ListItems[i];

                    Item.StyledSettings :=
                      Item.StyledSettings - [TStyledSetting.Size];

                    FS := Item.TextSettings.Font.Size * FScale;
                    Item.TextSettings.Font.Size := FS;

                    if H < FS then
                      H := FS;
                  end;

                  H := H + 9;
                  if ListBox.ItemHeight = 0 then
                    ListBox.ItemHeight := H
                  else
                    H := ListBox.ItemHeight;

                  Wnd.ClientSize :=
                    TSize.Create(
                      Calc(R.Width - 2),
                      Trunc(H * (ListBox.Items.Count + 1)));

                  Break;
                end;

            end;
          end;
      finally
        Wnd.Form.EndUpdate;
      end;
    end
  );
end;

procedure TFormDetector.FormHide(Sender: TObject);
var
  Wnd: TWinWindowHandle;
begin
  if not (Sender is TCustomPopupForm) then
    Exit;

  Wnd := WindowHandleToPlatform(TCustomPopupForm(Sender).Handle);
  if Wnd = nil then
    Exit;

  Wnd.SetForcedScale(FScale);

  if Wnd.Form.ParentForm <> nil then
    Wnd.Form.ParentForm.Invalidate;
end;

procedure TFormDetector.FormShow(Sender: TObject);
var
  Wnd: TWinWindowHandle;
  Child: TFmxObject;
  Control: TControl absolute Child;
begin
  if not (Sender is TCustomPopupForm) then
    Exit;

  Wnd := WindowHandleToPlatform(TCustomPopupForm(Sender).Handle);
  if Wnd = nil then
    Exit;

  Wnd.SetForcedScale(1);
  Wnd.ScaleChanged;

  Wnd.Form.BeginUpdate;
  try
    for Child in Wnd.Form.Children do
      if Child is TControl then
        Control.Visible := False;
  finally
    Wnd.Form.EndUpdate;
  end;
end;

var
  GFormDetector: TFormDetector;
initialization
  GFormDetector := TFormDetector.Create;
finalization
  GFormDetector.DisposeOf;
end.