Quadratische Thumbnails erstellen

[capo]

Hallo,
hier im Forum sind unzählige Beispiele wie Thumbnails erstellt werden z.B.
http://www.delphipraxis.net/105189-t...rkleinern.html

Oder dieses:

Delphi-Quellcode:

procedure SaveImage(inBmp: TBitmap32; filename: string);
var jpeg: TJPEGImage;
  bmp: TBitmap;
begin
  jpeg := TJPEGImage.Create;
  bmp := TBitmap.Create;
  try
    bmp.Assign(inBmp);
    jpeg.CompressionQuality := 100;
    jpeg.Assign(bmp);

    jpeg.SaveToFile(filename);
  finally
    jpeg.Free;
    bmp.Free;
  end;
end;



procedure resizePicture(infile: string; outfile: string; width, height: integer;
  aspectratio: boolean);
var srcpic, destpic: TBitmap32;
  destrect, srcrect: TRect;
begin
  srcpic := TBitmap32.Create;
  destpic := TBitmap32.Create;
  try
    srcpic.LoadFromFile(infile);
    if aspectratio = true then begin
      if srcpic.Height > srcpic.Width then begin
        width := height * srcpic.width div srcpic.height;
      end else begin
        height := width * srcpic.Height div srcpic.Width;
      end;
    end;
    try
      destpic.width := width;
      destpic.height := height;
      destrect := Rect(0, 0, destpic.width, destpic.height);
      srcrect := Rect(0, 0, srcpic.width, srcpic.height);
      srcpic.SetSize(67, 67);
      srcpic.Stretch(NewWidth, NewHeight, sfLanczos3, 0, BMP);
          // srcpic.StretchFilter:=sfLanczos; FUNKTIONIERT NICHT, WARUM?
      destpic.Draw(destrect, srcrect, srcpic);
    finally
      srcpic.free;
    end;
    SaveImage(destpic, outfile);
  finally
    destpic.free;
  end;
end;

Ich habe das Problem das ich quadratische Thumbnails brauche.
Die Ursprungsbilder sind hoch- und querformatig.
Wenn ich auf eine bestimmte Breite oder Höhe reduziere und den Rest stretche sieht es unter Umständen richtig verzehrt aus.

Hat jemand eine Idee wie mir das gelingen könnte?

Gruß
capo

[Matze]

Ermittel doch einfach die kürzere der beiden Seiten (simpler Vergleich) und nimm den als Kante des Quadrats und erstellst damit z.B.ein neues quadratisches Bild.
Die Differenz zwischen langer und kurzer Seite geteilt durch 2 ist das, was du an jeder Seite abschneiden musst.

Einfach entsprechend aufs neue, quadratische Bild kopieren und fertig.

[Bummi]

Delphi-Quellcode:

Procedure DrawBMPToCanvas(bmp:TBitmap;Canvas:TCanvas;Destrect:TRect);
var
    x,y,x1,y1:Double;
    Arect:TRect;
begin
      y:=bmp.Height;
      x:=bmp.Width;
      y1:=y/(Destrect.Right-Destrect.Left);
      x1:=x/(Destrect.Bottom-Destrect.Top);
      if x1<y1 then x1:=y1 ;
      x:=x/x1;
      y:=y/x1;
      Arect.left:=Destrect.Left+((Destrect.Right-Destrect.Left)-round(x)) div 2 ;
      Arect.top:=Destrect.Top+((Destrect.Bottom-Destrect.Top)-round(y)) div 2;
      Arect.right:=Arect.left+round(x);
      Arect.bottom:=Arect.top+round(y);
      Canvas.Fillrect(Destrect);
      Canvas.stretchdraw(Arect,bmp);
end;

oder mit GDIPAPI, GDIPOBJ

Delphi-Quellcode:

Procedure ScaleImage(Const source,dest:String;DestWidth,DestHeight:Integer;Qual:Integer=92;WithOutMargins:Boolean=false;BgColor:TColor=ClWhite);
var
  HDCImage:TImage;
  graphics : TGPGraphics;
  image: TGPImage;
  width, height: Integer;
  faktor:Double;
  destx,desty:Double;
  Ext:String;
begin

  Ext := UpperCase(StringReplace(ExtractFileExt(dest),'.','',[]));
  image:= TGPImage.Create(source);
  width  := image.GetWidth;
  height := image.GetHeight;
  if (DestWidth / width) < (DestHeight/Height) then faktor  := (DestWidth / width) else faktor:= (DestHeight/Height);
  HDCImage:=TImage.Create(nil);
  if WithOutMargins then
    begin
    HDCImage.Width  :=  Trunc(faktor * width);
    HDCImage.Height :=  Trunc(faktor * height);
    destx :=  0;
    desty :=  0;
    end
  else
    begin
    HDCImage.Width:=DestWidth;
    HDCImage.Height:=DestHeight;
    destx :=  (DestWidth - faktor * width) / 2;
    desty :=  (DestHeight - faktor * Height) / 2
    end;
  if BgColor<>clWhite then
    begin
      HDCImage.Canvas.Brush.Color:=BgColor;
      HDCImage.Canvas.Fillrect(Rect(0,0,HDCImage.Width,HDCImage.Height));
    end;
  graphics := TGPGraphics.Create(HDCImage.Canvas.Handle);
  graphics.SetInterpolationMode(InterpolationModeHighQualityBicubic);

  graphics.DrawImage(
    image,
    MakeRect(destx,  desty , faktor * width, faktor * height),  // destination rectangle
    0, 0,        // upper-left corner of source rectangle
    width,       // width of source rectangle
    height,      // height of source rectangle
    UnitPixel);
  image.Free;
  HDCImage.invalidate;
  ForceDirectories(ExtractFilePath(dest));
  if ext = 'BMP' then HDCImage.Picture.Bitmap.SaveToFile(dest)
  else SaveBMPasJPG(dest,HDCImage.Picture.Bitmap,qual);
  graphics.Free;
  HDCImage.Free;

end;

[shmia]

Du hast ein grosses Rechteck und möchtest das verkleinert in ein Quadrat einpassen.
Also muss im Quadrat links und rechts bzw. oben und unten gleich viel Weissraum bleiben.

Zufällig habe ich hier eine Funktion in meiner Schublade:

Delphi-Quellcode:

{**************************************************************************
 * NAME:    MaintainAspectRatio
 * DESC:    Bewirkt, dass das Seitenverhältnis (AspectRatio) bei
 *          Vergrösserungen oder Verkleinerungen bebehalten wird
 *          Es wird nur Integerarithmetik verwendet 
 * PARAMS:  rect => das Zielrechteck
 *          w => Breite
 *          h => Höhe
 *************************************************************************}
procedure MaintainAspectRatio(var rect:TRect; w,h:Integer; Center:Boolean);
var
   w2, h2 : Integer;
   tmp, x : Integer;
begin
   w2 := rect.Right-rect.Left;
   h2 := rect.Bottom-rect.Top;
   Assert(w2 >= 0);
   Assert(h2 >= 0);
   Assert(w >= 0);
   Assert(h >= 0);


   tmp := w2 * h - w * h2;

   if tmp > 0 then
   begin
      // Zielbereich ist zu breit
      x := (w * h2) div h;  // neue Breite
      if Center then
      begin
         Inc(rect.Left, (w2-x) div 2);
      end;
      rect.Right := rect.Left + x;
   end
   else if tmp < 0 then
   begin
      // Zielbereich ist zu hoch
      x := (h * w2) div w;   // neue Höhe
      if Center then
      begin
         Inc(rect.Top, (h2-x) div 2);
      end;
      rect.Bottom := rect.Top + x;
   end
   else
      ;

   Assert(rect.Right >= rect.Left);
   Assert(rect.Bottom >= rect.Top);
   { nur zum Testen
   w2 := rect.Right-rect.Left;
   h2 := rect.Bottom-rect.Top;
   tmp := w2 * h - w * h2;

   tmp müsste ungefähr 0 sein.
   }
end;

Die Anwendung sieht so aus:

Delphi-Quellcode:

var
   zielrect : TRect;
begin
   zielrect := Rect(0,0, 63, 63);  // Grösse Thumbnail
   MaintainAspectRatio(zielrect, Bitmap.Width, Bitmap.Height, True);
   // jetzt ist zielrect so geändert, dass man das Bitmap mit StrechDraw
   // ohne Änderung des Seitenverhältnisses verkleinern kann

[DeddyH]

Dann hab ich auch noch einen: http://www.delphipraxis.net/859482-post4.html

[capo]

Danke, ihr seid der Hammer! :-D
Jetzt kann ich weiter machen.
Gruß
Capo

[shmia]

Zitat:

Zitat von DeddyH (Beitrag 1057230)

Dann hab ich auch noch einen...

Also mir gefällt das MaintainAspectRatio am Besten:
keine Divisionen, keine Fliesskommazahlen und keine Abhängigkeiten zu Bitmap, Canvas, Image...
:duck:

[capo]

Zitat:

Zitat von shmia (Beitrag 1057229)

Du hast ein grosses Rechteck und möchtest das verkleinert in ein Quadrat einpassen.
Also muss im Quadrat links und rechts bzw. oben und unten gleich viel Weissraum bleiben.

Geht es auch ohne Weissraum?
Es wäre nicht so schlimm wenn ein Teil fehlen würde.

Wie mache ich das hiermit?

Zitat:

// jetzt ist zielrect so geändert, dass man das Bitmap mit StrechDraw
// ohne Änderung des Seitenverhältnisses verkleinern kann

Gruss
capo

[stahli]

Ist nicht genau das, was Du suchst, aber mal der Vollständigkeit halber...
Ich habe ein Formular, mit dem man einen quadratischen Auszug aus einem Bild auswählen kann. Ist aber halt eine händische Lösung.

[capo]

Zitat:

Zitat von stahli (Beitrag 1057248)

Ist nicht genau das, was Du suchst, aber mal der Vollständigkeit halber...
Ich habe ein Formular, mit dem man einen quadratischen Auszug aus einem Bild auswählen kann. Ist aber halt eine händische Lösung.

Gute Idee, das macht der Simpleviewer auch, verkleinert und nimmt sich irgendein Quadrat aus dem Foto heraus.
Das würde mir absolut reichen!

Allerding nicht händisch. Es sind relativ viele Bilder zu bearbeiten.
Danke für deine Ergänzung

[Matze]

Lies doch, was man dir schreibt und guck nicht nur auf geposteten Code. ;)
Ich habe doch oben ein mögliches Prinzip erklärt.

Anbei ein schnell zusammengetippeltes Beispiel. Es geht auch sauberer und mit weniger temporären Bildern. Nur so finde ich den Weg einleuchtender.
Hab's nicht ausgiebig getestet, sondern nur grob.

[capo]

Zitat:

Zitat von Bummi (Beitrag 1057225)

Delphi-Quellcode:

  if ext = 'BMP' then HDCImage.Picture.Bitmap.SaveToFile(dest)
  else SaveBMPasJPG(dest,HDCImage.Picture.Bitmap,qual);
  graphics.Free;
  HDCImage.Free;

end;

Hallo,

das wir dbei mir angemeckert:

Delphi-Quellcode:

SaveBMPasJPG
[DCC Fehler] frmMain.pas(214): E2003 Undefinierter Bezeichner: 'SaveBMPasJPG'

Woran liegt das?
Danke!

[Bummi]

ich hatte nur einen Auschnitt meiner Tools geschickt, hier der fehlende Teil.

Delphi-Quellcode:

Procedure SaveBMPasJPG(Const FN:String;BMP:TBitmap;Qual:Integer);
var
  jp:TJpegImage;
begin
      jp:=TJpegImage.Create;
      jp.CompressionQuality :=  qual;
      try
      with jp do
        begin
          Assign(BMP);
          SaveToFile(fn)
        end;
      finally
      jp.Free;
      end;
end;

[jfheins]

Das ganze nennt sich übrigens "quadratisch" - mit d ;)

[capo]

Zitat:

Zitat von Matze (Beitrag 1057253)

Lies doch, was man dir schreibt und guck nicht nur auf geposteten Code. ;)
Ich habe doch oben ein mögliches Prinzip erklärt.

Anbei ein schnell zusammengetippeltes Beispiel. Es geht auch sauberer und mit weniger temporären Bildern. Nur so finde ich den Weg einleuchtender.
Hab's nicht ausgiebig getestet, sondern nur grob.

Merkwürdig, aber deinen Beitrag habe ich die ganze Zeit nicht gesehen.
Gruss

[capo]

Zitat:

Zitat von jfheins (Beitrag 1057280)

Das ganze nennt sich übrigens "quadratisch" - mit d ;)

Hehe danke...und ich hatte extra schon darauf geachtet. Stress!

[capo]

Hallo,
ich habe mitlerweile eine Lösung gefunden, leider sehen die Thumbs entweder zu pixeli oder zu unscharf aus.
Hat jemand eine Idee?
So sieht mein Code momentan aus:

Delphi-Quellcode:

procedure SquareMyJPG(JPGFilePathSource, JPGFilePathDest: string;
  SquareLengthPx: Integer);
var
  JPGOrig, JPGThumbSquare: TJPEGImage;
  BMPThumbNoSquare, BMPThumbSquare: TBitmap;
  IsLandscape: Boolean;
begin
  JPGOrig := TJPEGImage.Create;
  try
    JPGOrig.LoadFromFile(JPGFilePathSource);

    IsLandscape := JPGOrig.Width > JPGOrig.Height;

    BMPThumbNoSquare := TBitmap.Create;
    try
      // Thumbnail proportional skalieren
      if IsLandscape then
      begin
        BMPThumbNoSquare.Height := SquareLengthPx;
        BMPThumbNoSquare.Width := Round(SquareLengthPx * JPGOrig.Width /
          JPGOrig.Height);
      end
      else
      begin
        BMPThumbNoSquare.Height := Round(SquareLengthPx * JPGOrig.Height /
          JPGOrig.Width);
        BMPThumbNoSquare.Width := SquareLengthPx;
      end;

      BMPThumbNoSquare.Canvas.StretchDraw(
        Rect(0, 0, BMPThumbNoSquare.Width, BMPThumbNoSquare.Height),
        JPGOrig
        );

      // Überflüssiges wegschnibbeln
      BMPThumbSquare := TBitmap.Create;
      try

        BMPThumbSquare.Width := SquareLengthPx;
        BMPThumbSquare.Height := SquareLengthPx;

        {
        if not IsLandscape then
          BMPThumbSquare.Canvas.Draw(
            -(BMPThumbNoSquare.Width - BMPThumbNoSquare.Height) div 2,
            0,
            BMPThumbNoSquare
          )
        else
          BMPThumbSquare.Canvas.Draw(
            -(BMPThumbNoSquare.Height - BMPThumbNoSquare.Width) div 2,
            0,
            BMPThumbNoSquare
          );
        }
        BMPThumbSquare.Canvas.CopyRect(Rect(0, 0, SquareLengthPx,
          SquareLengthPx), BMPThumbNoSquare.Canvas, Rect(0, 0, SquareLengthPx,
          SquareLengthPx));

        BMPThumbSquare.PixelFormat := pf24Bit;
        //   smoothH(BMPThumbSquare);
         // smoothV(BMPThumbSquare);
        JPGThumbSquare := TJPEGImage.Create;
        try
          //  JPGThumbSquare.Width := SquareLengthPx;
         // JPGThumbSquare.Height := SquareLengthPx;

          Antialiasing(BMPThumbSquare, Rect(0, 0, BMPThumbSquare.Width, BMPThumbSquare.Height), 10);
          // Sharpen(BMPThumbSquare,BMPThumbSquare,2);
          JPGThumbSquare.Assign(BMPThumbSquare);
          JPGThumbSquare.CompressionQuality := 100;
          JPGThumbSquare.Compress;
          JPGThumbSquare.Smoothing := not JPGThumbSquare.Smoothing;
          JPGThumbSquare.SaveToFile(JPGFilePathDest);

        finally
          FreeAndNil(JPGThumbSquare);
        end;
      finally
        FreeAndNil(BMPThumbSquare);
      end;
    finally
      //   BMPThumbNoSquare.SaveToFile('C:\bmpnosquare.bmp');
      FreeAndNil(BMPThumbNoSquare);
    end;
  finally

    FreeAndNil(JPGOrig);
  end;
end;

[stahli]

Zeig doch mal, was Du unter pixelig bzw. unscharf verstehst...

[Matze]

Zitat:

Zitat von capo (Beitrag 1059170)

ich habe mitlerweile eine Lösung gefunden ...

Hast meinen Anhang doch noch gesehen. ;)

Die Standardfunktionen in Delphi machen leider oft verpixelte Bilder. Wobei es irgendwo einen Code-Schnippsel gab, der das ganz gut hinbekommen hat. Ich finde ich auf Anhieb jedoch nicht.
Du kannst dir die Graphics32-Library mal ansehen. Damit erhältst du Ergebnisse wie aus einem guten Bildbearbeitungsprogramm.

Edit: Der Code aus dem SDC könnte es gewesen sein.

[DeddyH]

Würde es nicht genügen, SetStretchBltMode mit halftone aufzurufen und dann mit StretchBlt zu resizen?

[Bummi]

Hast Du es mal mit GDI+ und
graphics.SetInterpolationMode(InterpolationModeHig hQualityBicubic);

Positing #3

versucht, IMHO das Optimum

[Satty67]

Schnell versucht (evtl. falsch)

Delphi-Quellcode:

SetStretchBltMode(ThumbBitmap.Canvas.Handle, HALFTONE);

.
bringt keine Besserung. Weder mit Canvas.StrechDraw, noch direkt mit StretchBlt().

In C# gibt es eine Thumbnail-Methode im Image-Objekt, das sehr gute Ergebnisse liefert. Basiert auch auf GDI+. Würde also auch Bummis Rat empfehlen.

[Bummi]

Falls noch Interesse besteht, ich habe es mal maximal eingedampft

Delphi-Quellcode:

//2010 Thomas Wassermann www.explido-software.de
interface
uses  Windows,  Classes, Graphics,GDIPAPI,GDIPOBJ, StdCtrls, jpeg, ActiveX;

Procedure ScaleImage(source:TGraphic;dest:TCanvas;DestRect:Trect;Center:Boolean=true);overload;
implementation


Procedure ScaleImage(source:TGraphic;dest:TCanvas;DestRect:Trect;Center:Boolean=true);overload;
var
  graphics : TGPGraphics;
  image: TGPImage;
  width, height: Integer;
  faktor:Double;
  STR : TMemoryStream;
  X, Y:Double;
begin
  STR := TMemoryStream.Create;
  source.SaveToStream(STR);
  STR.Position := 0;
  image:= TGPImage.Create(TStreamAdapter.Create(Str));
  try
  width := image.GetWidth;
  height := image.GetHeight;
  if ((DestRect.Right - DestRect.Left) / width) < ((DestRect.Bottom -DestRect.Top)/Height) then faktor := (DestRect.Right - DestRect.Left) / width else faktor:= ((DestRect.Bottom -DestRect.Top)/Height);
  Faktor := ABS(Faktor);
  if Center then
      begin
        X := ((Destrect.Right - Destrect.Left) - faktor * width ) / 2;
        Y := ((Destrect.Bottom - Destrect.Top) - faktor * Height ) / 2;
      end
  else
      begin
        X := Destrect.Left;
        Y := Destrect.Top;

      end;
  graphics := TGPGraphics.Create(dest.Handle);
  try
    graphics.SetInterpolationMode(InterpolationModeHighQualityBicubic);
    graphics.DrawImage( image, MakeRect(X, Y , faktor * width, faktor * height),  0, 0, width,  height, UnitPixel);
  finally
    graphics.Free;
  end;
  finally
  STR.Free;
  image.Free;
  end;
end;
end;

[Bummi]

Zur besseren Wiederverwendbarkeit der TGPImages aus TGraphics habe ich eine kleine Wrapperklasse geschrieben, wer's brauchen kann...

Delphi-Quellcode:

Type TGPImageWrapper=Class(TObject)
       private
       FImage: TGPImage;
       FStream: TMemoryStream;
       public
       Constructor Create(AGraphic:TGraphic);
       Destructor Destroy;override;
       Public
       Property Image:TGPImage read FImage;
End;

________
{ TGPImageWrapper }

constructor TGPImageWrapper.Create(AGraphic: TGraphic);
begin
  FStream := TMemoryStream.Create;
  AGraphic.SaveToStream(FStream);
  Fimage:= TGPImage.Create(TStreamAdapter.Create(FStream));
end;

destructor TGPImageWrapper.Destroy;
begin
  FImage.Free;
  FStream.Free;
  inherited;
end;