function ScaleRect(var dst: TRect; ref: TRect): Boolean; overload;
var
  dw, dh, rw, rh: Integer;
  xyscale: Double;
begin
  dw := dst.Right - dst.Left;
  dh := dst.Bottom - dst.Top;
  rw := ref.Right - ref.Left;
  rh := ref.Bottom - ref.Top;
  Result := (dw > 0) and (dh > 0);
  if Result then
  begin
    xyscale := dw / dh;
    if dw > dh then
    begin
      dw := rw;
      dh := Trunc(rw / xyscale);
      if dh > rh then
      begin
        dh := rh;
        dw := Trunc(rh * xyscale);
      end;
    end
    else
    begin
      dh := rh;
      dw := Trunc(rh * xyscale);
      if dw > rw then
      begin
        dw := rw;
        dh := Trunc(rw / xyscale);
      end;
    end;
  end;
  with dst do
  begin
    Left := ref.Left;
    Top := ref.Top;
    Right := Left + dw;
    Bottom := Top + dh;
  end;
  OffsetRect(dst, (rw - dw) div 2, (rh - dh) div 2)
end;
 

function ScaleRect(var rc: TRect; p: TPoint; n: Integer): Boolean; overload;
var
  xyscale, xscale, yscale: Double;
  w, h, l, t, r, b: Integer;
begin
  Result := n <> 0;
  if not Result then Exit;
  with rc do
  begin
    if Top = Bottom then xyscale := 0
    else xyscale := (Right - Left) / (Bottom - Top);
    if p.x = Right then xscale := MaxInt
    else xscale := (p.x - Left) / (Right - p.x);
    if p.y = Bottom then yscale := MaxInt
    else yscale := (p.y - Top) / (Bottom - p.y);
  end;
  if xyscale < 0 then xyscale := -xyscale;
  if xscale < 0 then xscale := 1;
  if yscale < 0 then yscale := 1;
  if xyscale = 0 then
  begin
    w := 0; h := 0;
    with rc do
    begin
      if Right - Left = 0 then
        h := n * 2;
      if Bottom - Top = 0 then
        w := n * 2;
    end;
  end
  else
  begin
    if xyscale < 1 then
    begin
      w := n * 2;
      h := Trunc(w / xyscale);
    end
    else
    begin
      h := n * 2;
      w := Trunc(h * xyscale);
    end;
  end;
  l := Trunc(xscale / (xscale + 1) * w);
  t := Trunc(yscale / (yscale + 1) * h);
  r := Trunc(w - l);
  b := Trunc(h - t);
  with rc do
  begin
    Result := (Left - l <= Right + r) and (Top - t <= Bottom + b);
    if Result then
    begin
      Left := Left - l;
      Top := Top - t;
      Right := Right + r;
      Bottom := Bottom + b;
    end;
  end;
end;
 

  function ScaleBitmap(DstBitmap: TBitmap; var RefRect: TRect): Boolean;
  var
    DstRect: TRect;
    tmpBitmap: TBitMap;
  begin
    DstRect := DstBitmap.Canvas.ClipRect;
    Result := ScaleRect(DstRect, RefRect);
    if not Result then Exit;
    tmpBitmap := TBitMap.Create;
    try
      tmpBitmap.Width := RefRect.Right - RefRect.Left;
      tmpBitmap.Height := RefRect.Bottom - RefRect.Top;
      tmpBitmap.Canvas.StretchDraw(DstRect, DstBitmap);
      DstBitmap.Assign(tmpBitmap);
    finally
      tmpBitmap.Free;
    end;
  end;