unit uscaleby;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,Forms,Controls;

type
  TCustomClassScaler=tclass;
  TScaleProcedure=procedure(const AControl: TControl;const AOrigin,ATarget: SizeUint);

  TRegisteredScaler=record
    ClassToScale: TCustomClassScaler;
    ClassScaleProcedure: TScaleProcedure;
  end;

procedure ScaleBy(const AControl: TControl;const AOrigin,ATarget: SizeUint);
procedure ScaleByRecursive(const AControl: TControl;const AOrigin,ATarget: SizeUint);
procedure ScaleRectBy(var ARect: TRect;const AOrigin,ATarget: SizeUint);
procedure ScaleByRegisterScaler(const AScaleClass: tclass;const AScaler: TScaleProcedure);

implementation

var
  Scalers: array of TRegisteredScaler;

function FindRegisteredScaler(const AControl: TControl): TScaleProcedure; forward;

procedure ScaleBy(const AControl: TControl; const AOrigin, ATarget: SizeUint
  );
var
  NewOrigin: TPoint;
  NewSize: TPoint;
  TheRect: TRect;
begin
  if AOrigin=ATarget then exit;
  //If control is aligned only some things should be chaned based in which
  //alignement it has.
  if AControl.Align=alClient then begin
    //Nothing to do, it has been autoresized when the parent has been resized.
    Exit;
  end;

  //First scale the constraints.
  TheRect.Left   := AControl.Constraints.MinWidth;
  TheRect.Right  := AControl.Constraints.MaxWidth;
  TheRect.Top    := AControl.Constraints.MinHeight;
  TheRect.Bottom := AControl.Constraints.MaxHeight;
  ScaleRectBy(TheRect,AOrigin,ATarget);
  AControl.Constraints.MinWidth  := TheRect.Left;
  AControl.Constraints.MaxWidth  := TheRect.Right;
  AControl.Constraints.MinHeight := TheRect.Top;
  AControl.Constraints.MaxHeight := TheRect.Bottom;

  //Now scale the origin and size of the control.
  TheRect.Left   := AControl.Left;
  TheRect.Right  := AControl.Width;
  TheRect.Top    := AControl.Top;
  TheRect.Bottom := AControl.Height;
  ScaleRectBy(TheRect,AOrigin,ATarget);
  if (AControl.Align=AlNone) or (AControl.Align=alCustom) then begin
    if (akLeft in AControl.Anchors) then begin
      AControl.Left   := TheRect.Left;
    end;
    if not (akRight in AControl.Anchors) then begin
      AControl.Width  := TheRect.Right;
    end;
    if (akTop in AControl.Anchors) then begin
      AControl.Top    := TheRect.Top;
    end;
    if not (akBottom in AControl.Anchors) then begin
      AControl.Height := TheRect.Bottom;
    end;
  end else begin
    if ((AControl.Align=alTop) or (AControl.Align=alBottom)) and (not (akBottom in AControl.Anchors)) then begin
      //Only scale the height...
      AControl.Height := TheRect.Bottom;
    end else if ((AControl.Align=alLeft) or (AControl.Align=alRight)) and (not (akRight in AControl.Anchors)) then begin
      //Only scale the width...
      AControl.Width := TheRect.Right;
    end;
  end;
  TheRect.Left   := AControl.Left;
  TheRect.Right  := AControl.Width;
  TheRect.Top    := AControl.Top;
  TheRect.Bottom := AControl.Height;
end;

procedure ScaleByRecursive(const AControl: TControl; const AOrigin,
  ATarget: SizeUint);
var
  j: SizeUint;
  TheControl: TControl;
  TheWinControl: TWinControl;
  Scaler: TScaleProcedure;
begin
  if AOrigin=ATarget then exit;
  Scaler:=FindRegisteredScaler(AControl);
  Scaler(AControl,AOrigin,ATarget);
  if AControl is TWinControl then begin
    TheWinControl:=TWinControl(AControl);
    if TheWinControl.ControlCount>0 then begin
      for j := 0 to TheWinControl.ControlCount-1 do begin
        TheControl:=TheWinControl.Controls[j];
        if TheControl is TControl then begin
          ScaleByRecursive(TheWinControl.Controls[j],AOrigin,ATarget);
        end;
      end;
    end;
  end;
end;

procedure ScaleRectBy(var ARect: TRect; const AOrigin, ATarget: SizeUint);
begin
  ARect.Top:=ARect.Top*ATarget div AOrigin;
  ARect.Left:=ARect.Left*ATarget div AOrigin;
  ARect.Right:=ARect.Right*ATarget div AOrigin;
  ARect.Bottom:=ARect.Bottom*ATarget div AOrigin;
end;

procedure ScaleByRegisterScaler(const AScaleClass: tclass;
  const AScaler: TScaleProcedure);
begin
  SetLength(Scalers,Length(Scalers)+1);
  with Scalers[High(Scalers)] do begin
    ClassToScale:=AScaleClass;
    ClassScaleProcedure:=AScaler;
  end;
end;

function FindRegisteredScaler(const AControl: TControl): TScaleProcedure;
var
  j: SizeInt;
begin
  for j := 0 to High(Scalers) do begin
    if AControl.ClassType=Scalers[j].ClassToScale then begin
      Result:=Scalers[j].ClassScaleProcedure;
      Exit;
    end;
  end;
  //Default is the default ScaleBy
  Result:=@ScaleBy;
end;

end.