Procedure zum Exakten Verkleinern von Jpegs

[Cicaro]

Hier, hab' hier irgendwie 'was ausgekramt:

Delphi-Quellcode:

procedure DrawStretched(B:TBitmap;xp,yp:Real);

  var
    H:TBitmap;
    p1,p2,p3,p4:Real;
    x,y:Integer;
    Rr,Gg,Bb:Byte;

begin
  H:=TBitmap.Create;
  H.PixelFormat:=pf32Bit;
  H.Width:=Round(B.Width*xp);
  H.Height:=Round(B.Height*yp);

  for x:=0 to H.Width-1 do
    for y:=0 to H.Height-1 do
      begin
        p1:=1-x/xp+Trunc(x/xp)+1-y/yp+Trunc(y/yp);p2:=x  /xp-Trunc(x/xp)+1-y/yp+Trunc(y/yp);
        p3:=1-x/xp+Trunc(x/xp)+y  /yp-Trunc(y/yp);p4:=x  /xp-Trunc(x/xp)+y  /yp-Trunc(y/yp);

        Rr:=Trunc((GetRed(B.Canvas.Pixels[Trunc(x/xp),Trunc(y/yp)])*p1+
          GetRed(B.Canvas.Pixels[Trunc(x/xp)+1,Trunc(y/yp)])*p2+
          GetRed(B.Canvas.Pixels[Trunc(x/xp),Trunc(y/yp)+1])*p3+
          GetRed(B.Canvas.Pixels[Trunc(x/xp)+1,Trunc(y/yp)+1])*p4)/4);

        Gg:=Trunc((GetGreen(B.Canvas.Pixels[Trunc(x/xp),Trunc(y/yp)])*p1+
          GetGreen(B.Canvas.Pixels[Trunc(x/xp)+1,Trunc(y/yp)])*p2+
          GetGreen(B.Canvas.Pixels[Trunc(x/xp),Trunc(y/yp)+1])*p3+
          GetGreen(B.Canvas.Pixels[Trunc(x/xp)+1,Trunc(y/yp)+1])*p4)/4);

        Bb:=Trunc((GetBlue(B.Canvas.Pixels[Trunc(x/xp),Trunc(y/yp)])*p1+
          GetBlue(B.Canvas.Pixels[Trunc(x/xp)+1,Trunc(y/yp)])*p2+
          GetBlue(B.Canvas.Pixels[Trunc(x/xp),Trunc(y/yp)+1])*p3+
          GetBlue(B.Canvas.Pixels[Trunc(x/xp)+1,Trunc(y/yp)+1])*p4)/4);

        H.Canvas.Pixels[x,y]:=Bb*65536+Gg*256+Rr;
      end;
  B.Assign(H);
  H.Free;
end;

Müsste glaub' ich gute Ergebnisse liefern, wenn die Streckfaktoren nicht zu groß bzw. nicht zu klein sind.

Hier der Vollständigkeit halber:

Delphi-Quellcode:

function GetRed(C:TColor):Byte;
begin
  Result:=C;
end;

function GetGreen(C:TColor):Byte;
begin
  Result:=C shr 8;
end;

function GetBlue(C:TColor):Byte;
begin
  Result:=C shr 16;
end;