Недостающий вариант Image WrapMode

[krapotkin]

Мне очень не хватает для TImage еще одного варианта WrapMode - что-то типа FitNoEnvelope.

Сейчас Fit имеет целью полный показ картинки с сохранением пропорций, а мне для бэкграундов всяких чаще нужен вариант с полным заполнением имеющегося места, т.е. при масштабировании выбирается не min(Scale.X,Scale.Y) a max(Scale.X,Scale.Y) вкупе с центровкой картинки

 

Нет таких планов, случайно?

Изменено 13 августа, 2015 пользователем krapotkin

[AngryOwl]

Особо править нет времени, разберетесь. Все просто - это компонент, унаследованный от стандартного TImage, с теми свойствами, которые Вам нужны.

unit Sphere.ImageEx;

interface

uses
  System.Classes, System.Types, FMX.Types, FMX.Objects, FMX.Graphics;

  type
    TBitmapFit = (bfDefault, bfWidth, bfHeight, bfBoth);

    TImageEx = class(TImage)
    private
      FBitmapDisplayRect: TRectF;
      procedure SetBitmapFit(const Value: TBitmapFit);
    protected
      FBitmapFit: TBitmapFit;
      procedure Paint; override;
    public
      constructor Create(AOwner: TComponent); override;

      function ImagePointToBitmap(const APoint: TPointF): TPointF;
      property BitmapDisplayRect: TRectF read FBitmapDisplayRect;
    published
      property BitmapFit: TBitmapFit read FBitmapFit write SetBitmapFit;
    end;

implementation

{ TImageEx }

constructor TImageEx.Create(AOwner: TComponent);
begin
  inherited;
  FBitmapFit := bfDefault;
  FBitmapDisplayRect := TRectF.Empty;
end;

function TImageEx.ImagePointToBitmap(const APoint: TPointF): TPointF;
begin
  Result := APoint;
  if not (BitmapDisplayRect.IsEmpty) and Assigned(Bitmap) then
  begin
    Result.X := Result.X - Trunc(BitmapDisplayRect.Left);
    if Bitmap.Width > BitmapDisplayRect.Width then
      Result.X := Result.X / (BitmapDisplayRect.Width / Bitmap.Width );

    Result.Y := Result.Y - Trunc(BitmapDisplayRect.Top);
    if Bitmap.Height > BitmapDisplayRect.Height then
      Result.Y := Result.Y / (BitmapDisplayRect.Height / Bitmap.Height );
  end;
end;

procedure TImageEx.Paint;
begin

  {весь код - в прикрепленном файлике}

  // всегда центрируем для этих методов отрисовки
  else if FBitmapFit <> bfDefault then
  begin
    // растягиваем по ширине с обрезкой верхнего/нижнего краев
    Canvas.BeginScene();
    try
      Coef := B.Width / B.Height;
      R := RectF(0, 0, B.Width, B.Height);

      if FBitmapFit = bfWidth then
        R := RectF(0, 0, Width, Width / Coef)
        else
        if FBitmapFit = bfHeight then
          R := RectF(0, 0, Height * Coef, Height)
          else
          if FBitmapFit = bfBoth then
          begin
            if Coef >= 1 then
              R := RectF(0, 0, Height * Coef, Height)
              else
              R := RectF(0, 0, Width, Width / Coef);
          end;

      RectCenter(R, LocalRect);
      Canvas.DrawBitmap(B, RectF(0, 0, B.Width, B.Height), R, AbsoluteOpacity, DisableInterpolation);
      FBitmapDisplayRect := R;
    finally
      Canvas.EndScene();
    end;
  end;
end;

procedure TImageEx.SetBitmapFit(const Value: TBitmapFit);
begin
  if FBitmapFit <> Value then
  begin
    FBitmapFit := Value;
    Paint();
  end;
end;

//initialization
//  RegisterFMXClasses([TImageEx]);

end.

Sphere.ImageEx.zip

Изменено 13 августа, 2015 пользователем AlexG

[krapotkin]

Большое спасибо за готовое решение. Я примерно то же делал ручками через копирование по месту.

Конечно, было бы круто, чтобы эта функциональность попала в стандартный image.

Там ведь есть всякие варианты типа TRectangle.Fill, в которые тоже можно пихать картинки...

[AngryOwl]

Не за что

Тоже хотелось бы видеть что-то подобное в стандартных... Часто требуются подобное