delphi - resolucion - Cómo hacer zoom manteniendo correctamente la relación de aspecto

relaciones de aspecto pantalla

Question

Pues este es mi objetivo. Use el botón izquierdo del mouse para desplazarse por la imagen, el botón derecho del mouse para elegir el rectángulo de zoom y haga doble clic para restaurar el zoom completo.

Actualmente me he cansado, hasta ahora he encontrado que NO tiene que ver con la forma en que cargo las imágenes o que muestro la imagen, sino algo con la forma en que pinta. La imagen en pantalla siempre llena el área del cliente del control, independientemente de la forma del formulario o la imagen de origen, por lo que la relación de aspecto no se puede conservar. No estoy seguro de cómo cambiar esto o mantener la relación de aspecto. Así me da una imagen bonita y limpia.

Estoy publicando el código completo para mi unidad ZImage. Aunque creo que el problema está en Zimage.paint o Zimage.mouseup, pero me di cuenta de que si necesitaba ver una función dentro de una de esas, ayudaría a tenerlo todo publicado.

unit ZImage;

interface

uses
  Windows, Messages, SysUtils,jpeg, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;

type
  TZImage = class(TGraphicControl)
  private
    FBitmap        : Tbitmap;
    PicRect        : TRect;
    ShowRect       : TRect;
    FShowBorder    : boolean;
    FBorderWidth   : integer;
    FForceRepaint  : boolean;
    FMouse         : (mNone, mDrag, mZoom);
    FProportional  : boolean;
    FDblClkEnable  : boolean;
    FLeft        :integer;
    FRight        :integer;
    FTop             :integer;
    FBottom             :integer;
    startx, starty,
    oldx, oldy     : integer;
    procedure SetShowBorder(s:boolean);
    procedure SetBitmap(b:TBitmap);
    procedure SetBorderWidth(w:integer);
    procedure SetProportional(b:boolean);
  protected
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
                        X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
              X, Y: Integer); override;
  public
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    procedure DblClick; override;
  published
  procedure zoom(Endleft,EndRight,EndTop,EndBottom:integer);
    property ValueLeft    : integer read FLeft write FLeft;
    property ValueRight    : Integer read FRight write FRight;
    Property ValueTop         : Integer read FTop write FTop;
    Property ValueBottom         : Integer read FBottom write FBottom;
    property ShowBorder : boolean
                 read FShowBorder
                 write SetShowBorder default true;
    property KeepAspect : boolean
                 read FProportional
                 write SetProportional default true;
    property Bitmap : TBitmap
                 read FBitmap
                 write Setbitmap;
    property BorderWidth : integer
                 read FBorderWidth
                 write SetBorderWidth default 7;
    property ForceRepaint : boolean
                 read FForceRepaint
                 write FForceRepaint default true;
    property DblClkEnable : boolean
                 read FDblClkEnable
                 write FDblClkEnable default False;
    property Align;
    property Width;
    property Height;
    property Top;
    property Left;
    property Visible;
    property Hint;
    property ShowHint;
  end;

procedure Register;

implementation

 //This is the basic create options.
constructor TZImage.Create(AOwner:TComponent);
begin
   inherited;
   FShowBorder:=True;
   FBorderWidth:=7;
   FMouse:=mNone;
   FForceRepaint:=true;    //was true
   FDblClkEnable:=False;
   FProportional:=true;   //was true
   Width:=100; Height:=100;
   FBitmap:=Tbitmap.Create;
   FBitmap.Width:=width;
   FBitmap.height:=Height;
   ControlStyle:=ControlStyle+[csOpaque];
   autosize:= false;
   //Scaled:=false;
end;


//basic destroy frees the FBitmap
destructor TZImage.Destroy;
begin
   FBitmap.Free;
   inherited;
end;

//This was a custom zoom i was using to give the automated zoom effect
procedure TZimage.zoom(Endleft,EndRight,EndTop,EndBottom:integer);
begin

   while ((Endbottom <> picrect.bottom) or (Endtop <> picrect.top)) or ((endleft <> picrect.left) or (endright <> picrect.right)) do
     begin
       if picrect.left > endleft then
            picrect.left := picrect.left -1;
       if picrect.left < endleft  then  //starting
            picrect.left := picrect.left +1;

       if picrect.right > endright then   //starting
            picrect.right := picrect.right -1;
       if picrect.right < endright  then
            picrect.right := picrect.right +1;

       if picrect.top > endtop then
            picrect.top := picrect.top -1;
       if picrect.top < endtop then //starting
            picrect.top := picrect.top +1;

       if picrect.bottom > endbottom then  //starting
            picrect.bottom := picrect.bottom -1;
       if picrect.bottom < endbottom  then
           picrect.bottom := picrect.bottom +1;
       self.refresh;
     end;

end;

//this is the custom paint I know if i put
//Canvas.Draw(0,0,FBitmap);  as the methond it displays
//perfect but the zoom option is gone of course and
//i need the Zoom.
procedure TZImage.Paint;
var buf:TBitmap;
    coef,asps,aspp:Double;
    sz,a : integer;
begin

   buf:=TBitmap.Create;
   buf.Width:=Width;
   buf.Height:=Height;
   if not FShowBorder
     then ShowRect:=ClientRect
     else ShowRect:=Rect(ClientRect.Left,ClientRect.Top,
                         ClientRect.Right-FBorderWidth,
                         ClientRect.Bottom-FBorderWidth);
   ShowRect:=ClientRect;
   with PicRect do begin
    if Right=0 then Right:=FBitmap.Width;
    if Bottom=0 then Bottom:=FBitmap.Height;
   end;
   buf.Canvas.CopyMode:=cmSrcCopy;
   buf.Canvas.CopyRect(ShowRect,FBitmap.Canvas,PicRect);
   Canvas.CopyMode:=cmSrcCopy;
   Canvas.Draw(0,0,buf);
   buf.Free;
end;

procedure TZImage.MouseDown(Button: TMouseButton; Shift: TShiftState;
                            X, Y: Integer);
begin

//   if mbLeft<>Button then Exit;
   if not PtInRect(ShowRect,Point(X,Y)) and
      not PtInRect(Rect(ShowRect.Right,ShowRect.Bottom,
                        Width,Height),Point(X,Y)) then Exit;
   if PtInRect(Rect(ShowRect.Right,ShowRect.Bottom,
                    Width,Height),Point(X,Y)) then begin
      DblClick;
      Exit;
   end;
   //here click is in the picture area only
   startx:=x; oldx:=x;
   starty:=y; oldy:=y;
   if mbRight=Button then begin
      MouseCapture:=True;
      FMouse:=mZoom;
      Canvas.Pen.Mode:=pmNot;
   end else begin
      FMouse:=mDrag;
      Screen.Cursor:=crHandPoint;
   end;
end;



function Min(a,b:integer):integer;
begin
   if a<b then Result:=a else Result:=b;
end;
function Max(a,b:integer):integer;
begin
   if a<b then Result:=b else Result:=a;
end;



procedure TZImage.MouseMove(Shift: TShiftState; X, Y: Integer);
var d,s:integer;
    coef:Double;
begin
    if FMouse=mNone then Exit;
    if FMouse=mZoom then begin
       Canvas.DrawFocusRect(Rect(Min(startx,oldx),Min(starty,oldy),Max(startx,oldx),Max(starty,oldy)));
       oldx:=x; oldy:=y;
       Canvas.DrawFocusRect(Rect(Min(startx,oldx),Min(starty,oldy),Max(startx,oldx),Max(starty,oldy)));
    end;
    if FMouse=mDrag then begin
//horizontal movement
       coef:=(PicRect.Right-PicRect.Left)/(ShowRect.Right-ShowRect.Left);
       d:=Round(coef*(x-oldx));
       s:=PicRect.Right-PicRect.Left;
       if d>0 then begin
          if PicRect.Left>=d then begin
            PicRect.Left:=PicRect.Left-d;
            PicRect.Right:=PicRect.Right-d;
          end else begin
            PicRect.Left:=0;
            PicRect.Right:=PicRect.Left+s;
          end;
       end;
       if d<0 then begin
          if PicRect.Right<FBitmap.Width+d then begin
            PicRect.Left:=PicRect.Left-d;
            PicRect.Right:=PicRect.Right-d;
          end else begin
            PicRect.Right:=FBitmap.Width;
            PicRect.Left:=PicRect.Right-s;
          end;
       end;

//vertical movement
       coef:=(PicRect.Bottom-PicRect.Top)/(ShowRect.Bottom-ShowRect.Top);
       d:=Round(coef*(y-oldy));
       s:=PicRect.Bottom-PicRect.Top;
       if d>0 then begin
          if PicRect.Top>=d then begin
            PicRect.Top:=PicRect.Top-d;
            PicRect.Bottom:=PicRect.Bottom-d;
          end else begin
            PicRect.Top:=0;
            PicRect.Bottom:=PicRect.Top+s;
          end;
       end;

{There was a bug in the fragment below. Thanks to all, who reported this bug to me}
      if d<0 then begin
          if PicRect.Bottom<FBitmap.Height+d then begin
            PicRect.Top:=PicRect.Top-d;
            PicRect.Bottom:=PicRect.Bottom-d;
          end else begin
            PicRect.Bottom:=FBitmap.Height;
            PicRect.Top:=PicRect.Bottom-s;
          end;
       end;


       oldx:=x; oldy:=y;
       if FForceRepaint then Repaint
                        else Invalidate;
    end;
end;



procedure TZImage.MouseUp(Button: TMouseButton; Shift: TShiftState;
                          X, Y: Integer);
var coef:Double;
    t:integer;
    left,right,top,bottom : integer;
begin

   if FMouse=mNone then Exit;
   if x>ShowRect.Right then x:=ShowRect.Right;
   if y>ShowRect.Bottom then y:=ShowRect.Bottom;
   if FMouse=mZoom then begin  //calculate new PicRect
     t:=startx;
     startx:=Min(startx,x);
     x:=Max(t,x);
     t:=starty;
     starty:=Min(starty,y);
     y:=Max(t,y);
     FMouse:=mNone;
     MouseCapture:=False;
//enable the following if you want to zoom-out by dragging in the opposite direction}
{     if Startx>x then begin
        DblClick;
        Exit;
     end;}
     if Abs(x-startx)<5 then Exit;
     //showmessage(''picrect Left=''+inttostr(picrect.Left)+'' right=''+inttostr(picrect.Right)+'' top=''+inttostr(picrect.Top)+'' bottom=''+inttostr(picrect.Bottom));
     //startx and start y is teh starting x/y of the selected area
     //x and y is the ending x/y of the selected area
     if (x - startx < y - starty) then
     begin
       while (x - startx < y - starty) do
       begin
          x := x + 100;
          startx := startx - 100;
       end;
     end

     else if (x - startx > y - starty) then
     begin
        while (x - startx > y - starty) do
        begin
            y := y + 100;
            starty := starty - 100;
        end;
     end;

//picrect is the size of whole area
//PicRect.top and left are 0,0
//IFs were added in v.1.2 to avoid zero-divide
     if (PicRect.Right=PicRect.Left)
     then
        coef := 100000
     else
        coef:=ShowRect.Right/(PicRect.Right-PicRect.Left);    //if new screen coef= 1
     left:=Round(PicRect.Left+startx/coef);
     Right:=Left+Round((x-startx)/coef);

     if (PicRect.Bottom=PicRect.Top)
     then
        coef := 100000
     else
        coef:=ShowRect.Bottom/(PicRect.Bottom-PicRect.Top);
     Top:=Round(PicRect.Top+starty/coef);
     Bottom:=Top+Round((y-starty)/coef);
     //showmessage(inttostr(left)+'' ''+inttostr(Right)+'' ''+inttostr(top)+'' ''+inttostr(bottom));

     zoom(left,right,top,bottom);
     ValueLeft := left;
     ValueRight := Right;
     ValueTop := top;
     ValueBottom := bottom;
     end;
   if FMouse=mDrag then begin
     FMouse:=mNone;
     Canvas.Pen.Mode:=pmCopy;
     Screen.Cursor:=crDefault;
   end;

   Invalidate;
end;

procedure TZImage.DblClick;
begin
   zoom(0,FBitMap.Width,0,FBitMap.Height);
   ValueLeft := 0;
   ValueRight := FBitMap.Width;
   ValueTop := 0;
   ValueBottom := FBitMap.Height;
   //PicRect:=Rect(0,0,FBitmap.Width,FBitmap.Height);
   Invalidate;
end;

procedure TZImage.SetBitmap(b:TBitmap);
begin
   FBitmap.Assign(b);
   PicRect:=Rect(0,0,b.Width, b.Height);
   Invalidate;
end;

procedure TZImage.SetBorderWidth(w:integer);
begin
   FBorderWidth:=w;
   Invalidate;
end;

procedure TZImage.SetShowBorder(s:boolean);
begin
   FShowBorder:=s;
   Invalidate;
end;

procedure TZImage.SetProportional(b:boolean);
begin
   FProportional:=b;
   Invalidate;
end;

procedure Register;
begin
  RegisterComponents(''Custom'', [TZImage]);
end;

end.

Con este código puede registrar el componente ZImage y ver cómo se ejecuta ... si es necesario

Answer 1

La pregunta es clara, pero creo que el problema para responderla es cómo no volver a escribir el código completo para que sea comprensible para usted. Y como soy mejor programando y luego explicando, lo hice.

Creo que estás buscando algo como lo siguiente:

unit ZImage2;

interface

uses
  Windows, Messages, Classes, Controls, Graphics, StdCtrls, ExtCtrls, Math;

const
  DefAnimDuration = 500;

type
  TZImage = class(TGraphicControl)
  private
    FAlignment: TAlignment;
    FAnimDuration: Cardinal;
    FAnimRect: TRect;
    FAnimStartTick: Cardinal;
    FAnimTimer: TTimer;
    FBuffer: TBitmap;
    FCropRect: TRect;
    FImgRect: TRect;
    FLayout: TTextLayout;
    FPicture: TPicture;
    FPrevCropRect: TRect;
    FProportional: Boolean;
    FProportionalCrop: Boolean;
    FScale: Single;
    FSelColor: TColor;
    FSelecting: Boolean;
    FSelPoint: TPoint;
    FSelRect: TRect;
    procedure Animate(Sender: TObject);
    function HasGraphic: Boolean;
    procedure PictureChanged(Sender: TObject);
    procedure RealignImage;
    procedure SetAlignment(Value: TAlignment);
    procedure SetLayout(Value: TTextLayout);
    procedure SetPicture(Value: TPicture);
    procedure SetProportional(Value: Boolean);
    procedure UpdateBuffer;
  protected
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
    procedure ChangeScale(M: Integer; D: Integer); override;
    procedure DblClick; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X,
      Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X,
      Y: Integer); override;
    procedure Paint; override;
    procedure Resize; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Reset;
    function ScreenToGraphic(R: TRect): TRect;
    procedure Zoom(const ACropRect: TRect);
    procedure ZoomSelection(const ASelRect: TRect);
  published
    property Alignment: TAlignment read FAlignment write SetAlignment
      default taLeftJustify;
    property AnimDuration: Cardinal read FAnimDuration write FAnimDuration
      default DefAnimDuration;
    property Layout: TTextLayout read FLayout write SetLayout default tlTop;
    property Picture: TPicture read FPicture write SetPicture;
    property Proportional: Boolean read FProportional write SetProportional
      default False;
    property ProportionalCrop: Boolean read FProportionalCrop
      write FProportionalCrop default True;
    property SelColor: TColor read FSelColor write FSelColor default clWhite;
  published
    property Align;
    property Anchors;
    property AutoSize;
    property Color;
  end;

implementation

function FitRect(const Boundary: TRect; Width, Height: Integer;
  CanGrow: Boolean; HorzAlign: TAlignment; VertAlign: TTextLayout): TRect;
var
  W: Integer;
  H: Integer;
  Scale: Single;
  Offset: TPoint;
begin
  Width := Max(1, Width);
  Height := Max(1, Height);
  W := Boundary.Right - Boundary.Left;
  H := Boundary.Bottom - Boundary.Top;
  if CanGrow then
    Scale := Min(W / Width, H / Height)
  else
    Scale := Min(1, Min(W / Width, H / Height));
  Result := Rect(0, 0, Round(Width * Scale), Round(Height * Scale));
  case HorzAlign of
    taLeftJustify:
      Offset.X := 0;
    taCenter:
      Offset.X := (W - Result.Right) div 2;
    taRightJustify:
      Offset.X := W - Result.Right;
  end;
  case VertAlign of
    tlTop:
      Offset.Y := 0;
    tlCenter:
      Offset.Y := (H - Result.Bottom) div 2;
    tlBottom:
      Offset.Y := H - Result.Bottom;
  end;
  OffsetRect(Result, Boundary.Left + Offset.X, Boundary.Top + Offset.Y);
end;

function NormalizeRect(const Point1, Point2: TPoint): TRect;
begin
  Result.Left := Min(Point1.X, Point2.X);
  Result.Top := Min(Point1.Y, Point2.Y);
  Result.Right := Max(Point1.X, Point2.X);
  Result.Bottom := Max(Point1.Y, Point2.Y);
end;

{ TZImage }

procedure TZImage.Animate(Sender: TObject);
var
  Done: Single;
begin
  Done := (GetTickCount - FAnimStartTick) / FAnimDuration;
  if Done >= 1.0 then
  begin
    FAnimTimer.Enabled := False;
    FAnimRect := FCropRect;
  end
  else
    with FPrevCropRect do
      FAnimRect := Rect(
        Left + Round(Done * (FCropRect.Left - Left)),
        Top + Round(Done * (FCropRect.Top - Top)),
        Right + Round(Done * (FCropRect.Right - Right)),
        Bottom + Round(Done * (FCropRect.Bottom - Bottom)));
  UpdateBuffer;
  RealignImage;
  Invalidate;
end;

function TZImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
  Result := True;
  if not (csDesigning in ComponentState) or HasGraphic then
  begin
    if Align in [alNone, alLeft, alRight] then
      NewWidth := Round(FScale * FPicture.Width);
    if Align in [alNone, alTop, alBottom] then
      NewHeight := Round(FScale * FPicture.Height);
  end;
end;

procedure TZImage.ChangeScale(M, D: Integer);
var
  SaveAnchors: TAnchors;
begin
  SaveAnchors := Anchors;
  Anchors := [akLeft, akTop];
  FScale := FScale * M / D;
  inherited ChangeScale(M, D);
  Anchors := SaveAnchors;
end;

constructor TZImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csCaptureMouse, csClickEvents, csOpaque, csDoubleClicks];
  FAnimTimer := TTimer.Create(Self);
  FAnimTimer.Interval := 15;
  FAnimTimer.OnTimer := Animate;
  FAnimDuration := DefAnimDuration;
  FBuffer := TBitmap.Create;
  FPicture := TPicture.Create;
  FPicture.OnChange := PictureChanged;
  FProportionalCrop := True;
  FScale := 1.0;
  FSelColor := clWhite;
end;

procedure TZImage.DblClick;
begin
  if not HasGraphic then
    Reset
  else
    Zoom(Rect(0, 0, FPicture.Width, FPicture.Height));
  inherited DblClick;
end;

destructor TZImage.Destroy;
begin
  FPicture.Free;
  FBuffer.Free;
  inherited Destroy;
end;

function TZImage.HasGraphic: Boolean;
begin
  Result := (Picture.Width > 0) and (Picture.Height > 0);
end;

procedure TZImage.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  if (Button = mbRight) and HasGraphic and PtInRect(FImgRect, Point(X, Y)) then
  begin
    FSelPoint.X := X;
    FSelPoint.Y := Y;
    FSelRect := Rect(X, Y, X, Y);
    FSelecting := True;
    Canvas.Brush.Color := FSelColor;
    Canvas.DrawFocusRect(FSelRect);
  end;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TZImage.MouseMove(Shift: TShiftState; X, Y: Integer);
const
  HorzAlign: array[Boolean] of TAlignment = (taLeftJustify, taRightJustify);
  VertAlign: array[Boolean] of TTextLayout = (tlTop, tlBottom);
begin
  if FSelecting and PtInRect(FImgRect, Point(X, Y)) then
  begin
    Canvas.DrawFocusRect(FSelRect);
    FSelRect := NormalizeRect(FSelPoint, Point(X, Y));
    if (not FProportionalCrop) then
      FSelRect := FitRect(FSelRect, FPicture.Graphic.Width,
        FPicture.Graphic.Height, True, HorzAlign[X < FSelPoint.X],
        VertAlign[Y < FSelPoint.Y]);
    Canvas.DrawFocusRect(FSelRect);
  end;
  inherited MouseMove(Shift, X, Y);
end;

procedure TZImage.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  if FSelecting then
  begin
    FSelecting := False;
    Canvas.DrawFocusRect(FSelRect);
    if (Abs(X - FSelPoint.X) > Mouse.DragThreshold) or
        (Abs(Y - FSelPoint.Y) > Mouse.DragThreshold) then
      ZoomSelection(FSelRect);
  end;
  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TZImage.Paint;
begin
  Canvas.Brush.Color := Color;
  if HasGraphic then
  begin
    Canvas.StretchDraw(FImgRect, FBuffer);
    if FSelecting then
      Canvas.DrawFocusRect(FSelRect);
    with FImgRect do
      ExcludeClipRect(Canvas.Handle, Left, Top, Right, Bottom);
  end;
  Canvas.FillRect(Canvas.ClipRect);
end;

procedure TZImage.PictureChanged(Sender: TObject);
begin
  Reset;
end;

procedure TZImage.RealignImage;
begin
  if not HasGraphic then
    FImgRect := Rect(0, 0, 0, 0)
  else if FProportional then
    FImgRect := ClientRect
  else
    FImgRect := FitRect(ClientRect, FBuffer.Width, FBuffer.Height, True,
      FAlignment, FLayout);
end;

procedure TZImage.Reset;
begin
  FCropRect := Rect(0, 0, FPicture.Width, FPicture.Height);
  FAnimRect := FCropRect;
  UpdateBuffer;
  RealignImage;
  Invalidate;
end;

procedure TZImage.Resize;
begin
  RealignImage;
  inherited Resize;
end;

function TZImage.ScreenToGraphic(R: TRect): TRect;
var
  CropWidth: Integer;
  CropHeight: Integer;
  ImgWidth: Integer;
  ImgHeight: Integer;
begin
  CropWidth := FCropRect.Right - FCropRect.Left;
  CropHeight := FCropRect.Bottom - FCropRect.Top;
  ImgWidth := FImgRect.Right - FImgRect.Left;
  ImgHeight := FImgRect.Bottom - FImgRect.Top;
  IntersectRect(R, R, FImgRect);
  OffsetRect(R, -FImgRect.Left, -FImgRect.Top);
  Result := Rect(
    FCropRect.Left + Round(CropWidth * (R.Left / ImgWidth)),
    FCropRect.Top + Round(CropHeight * (R.Top / ImgHeight)),
    FCropRect.Left + Round(CropWidth * (R.Right / ImgWidth)),
    FCropRect.Top + Round(CropHeight * (R.Bottom / ImgHeight)));
end;

procedure TZImage.SetAlignment(Value: TAlignment);
begin
  if FAlignment <> Value then
  begin
    FAlignment := Value;
    RealignImage;
    Invalidate;
  end;
end;

procedure TZImage.SetLayout(Value: TTextLayout);
begin
  if FLayout <> Value then
  begin
    FLayout := Value;
    RealignImage;
    Invalidate;
  end;
end;

procedure TZImage.SetPicture(Value: TPicture);
begin
  FPicture.Assign(Value);
end;

procedure TZImage.SetProportional(Value: Boolean);
begin
  if FProportional <> Value then
  begin
    FProportional := Value;
    RealignImage;
    Invalidate;
  end;
end;

procedure TZImage.UpdateBuffer;
begin
  if HasGraphic then
  begin
    FBuffer.Width := FAnimRect.Right - FAnimRect.Left;
    FBuffer.Height := FAnimRect.Bottom - FAnimRect.Top;
    FBuffer.Canvas.Draw(-FAnimRect.Left, -FAnimRect.Top, FPicture.Graphic);
  end;
end;

procedure TZImage.Zoom(const ACropRect: TRect);
begin
  if HasGraphic then
  begin
    FPrevCropRect := FAnimRect;
    FCropRect := ACropRect;
    if FAnimDuration = 0 then
    begin
      FAnimRect := FCropRect;
      UpdateBuffer;
      RealignImage;
      Invalidate;
    end
    else
    begin
      FAnimStartTick := GetTickCount;
      FAnimTimer.Enabled := True;
    end;
  end;
end;

procedure TZImage.ZoomSelection(const ASelRect: TRect);
begin
  Zoom(ScreenToGraphic(ASelRect));
end;

end.

Código de muestra:

procedure TForm1.FormCreate(Sender: TObject);
begin
  FImage := TZImage.Create(Self);
  FImage.SetBounds(10, 10, 200, 300);
  FImage.Picture.LoadFromFile(''D:/Pictures/Mona_Lisa.jpg'');
  FImage.Alignment := taCenter;
  FImage.Layout := tlCenter;
  FImage.AutoSize := True;
  FImage.Parent := Self;
end;