// Hiermit kann man Bitmaps in Größe und/oder Seitenverhältnis
// ändern. Siehe auch: Bitmaps resamplen

// Getestet mit RS 10.4 unter Win11

uses 
  // Vcl.Graphics, 
  Winapi.Wincodec; 
 
var 
  bm: TBitmap; 
 
procedure TFormx.FormCreate(Sender: TObject); 
begin 
  bm := TBitmap.Create; 
end; 
 
procedure TFormx.FormDestroy(Sender: TObject); 
begin 
  FreeAndNil(bm); 
end; 
 
function ResizeBitmap(BMP: TBitmap; NewWidth, NewHeight: integer): Byte; 
const 
  GRZ = 8192; 
var 
  FCT: IWICImagingFactory; 
  SCL: IWICBitmapScaler; 
  WIC: TWICImage; 
  procedure NL; 
  begin 
    WIC.Free; 
    SCL := nil; 
    FCT := nil; 
  end; 
 
begin 
  if (NewWidth <= 0) or (NewHeight <= 0) or (NewWidth > GRZ) or (NewHeight > GRZ) 
  then 
  begin 
    Result := 1; 
    exit; 
  end; 
  Result := 0; 
  try 
    BMP.AlphaFormat := afIgnored; 
    WIC := TWICImage.Create; 
    WIC.Assign(BMP); 
    FCT := TWICImage.ImagingFactory; 
    FCT.CreateBitmapScaler(SCL); 
    try 
      SCL.Initialize(WIC.Handle, NewWidth, NewHeight, 
        WICBitmapInterpolationModeHighQualityCubic); 
      WIC.Handle := IWICBitmap(SCL); 
      BMP.Assign(WIC); 
    except 
      Result := 2; 
    end; 
    NL; 
  except 
    Result := 3; 
    NL; 
  end; 
end;

 
// Beispielaufruf 
procedure TFormx.Button1Click(Sender: TObject); 
var 
  I: integer; 
begin 
  bm.LoadFromFile('D:\Bilder\test.bmp'); 
  // zwecks Anschauung --- 
  I := bm.Width; 
  Canvas.Draw(10, 10, bm); 
  // -------------------- 
  Case ResizeBitmap(bm, 300, 300) of 
    0: 
      Canvas.Draw(20 + I, 10, bm); // z.B. 
    1: 
      showmessage('Abmaße unzulässig'); 
    2: 
      showmessage('Umsetzung nicht möglich'); 
  else 
    showmessage('Unbekannter Fehler'); 
  end; 
end;

Zugriffe seit 6.9.2001 auf Delphi-Ecke