Mirror

How to autoscale a TBitmap while keeping the aspect ratio (Views: 101)


Problem/Question/Abstract:

How to autoscale a TBitmap while keeping the aspect ratio

Answer:

Explanation on explicit demand!

procedure TForm1.Image1Paint(Sender: TObject);
var
  Bitmap: TBitmap;
  Breite, Hoehe: Real;
  links, rechts, oben, unten: integer;
  Feld: TRect;
begin
  Image1.Canvas.Pen.Color := Form1.Color;
  Image1.Canvas.Brush.Color := Form1.Color;
  Feld.Left := 0;
  Feld.Right := Image1.Width;
  Feld.Top := 0;
  Feld.Bottom := Image1.Height;
  Image1.Canvas.Rectangle(Feld);
  Application.ProcessMessages;
  Bitmap := TBitmap.Create;
  Bitmap.PixelFormat := pf24bit;
  Bitmap.LoadFromFile('C:\Bild.bmp');
  Breite := Bitmap.Width / Image1.Width;
  Hoehe := Bitmap.Height / Image1.Height;
  if Breite >= Hoehe then
  begin
    links := 0;
    rechts := Image1.Width;
    oben := (Image1.Height - Trunc(Bitmap.Height / Breite)) div 2;
    unten := oben + Trunc(Bitmap.Height / Breite);
  end
  else
  begin
    oben := 0;
    unten := Image1.Height;
    links := (Image1.Width - Trunc(Bitmap.Width / Hoehe)) div 2;
    rechts := links + Trunc(Bitmap.Width / Hoehe)
  end;
  Feld.Left := links;
  Feld.Right := rechts;
  Feld.Top := oben;
  Feld.Bottom := unten;
  Image1.Canvas.StretchDraw(Feld, Bitmap);
  Bitmap.Free;
end;

<< Back to main page