Kann man die Qualität von TImage verbessern?

[Popov]

Nur eine kurze Frage, und zwar interessiert es mich ob man die Qualität des TImage beim skalieren verbessern/ändern kann. Bekanntlich wird hier "hart" skaliert. Mich interessieren an der Stelle keine anderen Komponente oder Quellcode um es selbst zu machen. Um das geht es hier nicht.

Mich interessiert es nur ob man durch Tricks die Skalier-Art des TImage ändern kann.

[DeddyH]

Kann man, siehe SetStretchBltMode.

[Popov]

Kann es gerade nicht testen.

SetStretchBltMode kenne ich, nur wußte ich nicht, dass es auch bei TImage funktioniert.

[DeddyH]

Naja, nicht direkt im TImage, aber man kann es auf die enthaltene Grafik anwenden. Wobei es natürlich schöner wäre, wenn es eine entsprechende Property gäbe, aber so eine ist mir auch nicht bekant.

[Luckie]

TImage ist doch nur ein Container um Grafiken anzuzeigen. Die Qualität hängt von den Grafiken ab, Auflösung, Format (BMP, JPEG, ...), Größe...

[Bummi]

Ich habe hier noch einen alten Fetzen Code rumliegen, müsste umgebaut (TBitmap statt TImage und nicht aus/in Datei etc.) und resourcensicher gemacht werden, skaliert aber sehr sauber ... benötigt GDI+

Delphi-Quellcode:

{-----------------------------------------------------------------------------
  Procedure: ScaleOneImage
  Author:    Thomas Wassermann
  Date:      21-Nov-2006
  Arguments: Const source,dest:String;DestWidth,DestHeight:Integer
  Result:    None
  Remarks:   None
-----------------------------------------------------------------------------}
Procedure ScaleOneImage(Const source,dest:String;DestWidth,DestHeight:Integer;Qual:Integer=92;WithOutMargins:Boolean=false;BgColor:TColor=ClWhite;DoNotUpScale:Boolean=false);
var
  HDCImage:TImage;
  graphics : TGPGraphics;
  image: TGPImage;
  width, height: UINT;
  faktor:Double;
  destx,desty:Double;
  rct:TGPRectF;
  Ext:String;
begin

  Ext := UpperCase(StringReplace(ExtractFileExt(dest),'.','',[]));
  image:= TGPImage.Create(source);
  width  := image.GetWidth;
  height := image.GetHeight;


  if  ((width=DestWidth) and (height=DestHeight)) or (DoNotUpScale and ((width<=DestWidth) and (height<=DestHeight))) then
    begin
       image.Free;
       CopyFile(Pchar(Source),PChar(Dest),false);
    end
else
    begin
        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);
        {
        rct.x :=  destx ;
        rct.Y :=  desty * 1.0;
        rct.Width := faktor * width;
        rct.Height  := faktor * height;
        graphics.SetClip(rct);
        }
        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;
        if ext = 'BMP' then HDCImage.Picture.Bitmap.SaveToFile(dest)
        else SaveBMPasJPG(dest,HDCImage.Picture.Bitmap,qual);
        graphics.Free;
        HDCImage.Free;
    end;

end;

[Popov]

Zitat von Luckie:

TImage ist doch nur ein Container um Grafiken anzuzeigen. Die Qualität hängt von den Grafiken ab, Auflösung, Format (BMP, JPEG, ...), Größe...

Ich meine nicht die Qualität der Grafik selbst oder allgemein des TImage, sondern der Eigenschaft Scale bei TImage. Ist sie True, wird die Grafik bei Resize der Komponente automatisch angepaßt. Nur ist die Qualität dabei nicht so besonders gut. In der Regel kompensiere ich das über eine separate Routine. Nur betrachte ich es auf die Dauer als lästig. Scale von TImage ist ja praktisch, nur die Qualität ist bescheiden. Ich hoffte es gibt einen Trick.

@Bummi

Danke für den Code, nur geht es um TImage. Aber trotz dem danke für den Code. In der nächsten Zeit fange ich ein Grafikprojekt an, dann wird sich zuerst GDI+ ausführlich gangeguckt.

[himitsu]

Natürlich könnte man versuchen da etwas zu machen.

Du mußt nur rausbekommen wie/wo TImage zeichnet und dann ersetzt du den Code, welcher diese Skalierung nicht so schön übernimmt.
> Komponente ableiten und den besseren Code einbauen, welche dann das Zeichnen übernimmt.

procedure Paint; override;

[Medium]

@GDI+: Wenn du schon eine neue API lernst, dann würde ich was aktuelleres nehmen. Zumindest für neue Projekte, wo man nicht an 1001 Stellen ändern müsste. Ein großer Nachteil von GDI+ ist, dass es z.B. spätestens ab Win7 (unter Aero) nicht mehr hardwarebeschleunigt wird. Ich habe die genaue Quelle nicht mehr, aber in den Tiefen des MSDN war auch seitens MS die Empfehlung statt auf (das quasi deprecated) GDI+ besser auf Direct2D zu setzen.
Will man das nicht, so stellt auch die Graphics32 eine immens mächtige (und flotte) Alternative dar, die sogar mit fix und fertigen VCL Kompos daher kommt. Nachteil: Es ist "nur" eine Lib, kein OS-Feature, und da wird wohl ausser hier und da etwas Handassembliertes MMX/SSE auch keine Beschleunigung verwendet. (Es ist aber in sich schon vergleichsweise zügig.)

[himitsu]

Wenn ich's richtig gesehn hab, dann sind das vermutlich die kombinierten Codes für D7 bis XE3.

Delphi-Quellcode:

unit Unit11;

interface

uses
  {$IF CompilerVersion >= 22}
  Winapi.Windows, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.ExtCtrls, Winapi.UxTheme;
  {$ELSE}
  Windows, Classes, Graphics, Controls, ExtCtrls, UxTheme;
  {$IFEND}

type
  TImage2 = class(TImage)
  protected
    procedure Paint; override;
  end;
  TGraphicControlHack = class(TGraphicControl);

procedure register;

implementation

procedure register;
begin
  RegisterComponents('Zusätzlich', [TImage2]);
end;

procedure TImage2.Paint;
var
  DrawingCanvas: TCanvas;
  BlockDrawing: PBoolean;
  Save: Boolean;
  {$IF CompilerVersion > 15} // über D7
  PaintOnGlass: Boolean;
  MemDC: HDC;
  Rect: TRect;
  PaintBuffer: HPAINTBUFFER;
  {$IF CompilerVersion <= 18} // bis D2007
  LForm: TCustomForm;
  {$IFEND}
  {$IFEND}
begin
  DrawingCanvas := TGraphicControlHack(Self).Canvas; // (inherited Canvas) , allerdings von der vor-vorherigen Klasse, denn TImage hat dieses Anzeige-Canvas verdeckt und enthält nun das Zugriffs-Canvas auf das interne Bild
  BlockDrawing := PBoolean(PByte(@Transparent) + 1); // private FDrawing
  if csDesigning in ComponentState then
  begin
    DrawingCanvas.Pen.Style := psDash;
    DrawingCanvas.Brush.Style := bsClear;
    DrawingCanvas.Rectangle(0, 0, Width, Height);
  end;
  Save := BlockDrawing^;
  BlockDrawing^ := True;
  try
    {$IF CompilerVersion > 15}
    {$IF CompilerVersion <= 18}
    PaintOnGlass := DwmCompositionEnabled and not (csDesigning in ComponentState);
    if PaintOnGlass then
    begin
      LForm := GetParentForm(Self);
      PaintOnGlass := (LForm <> nil) and LForm.GlassFrame.FrameExtended and LForm.GlassFrame.IntersectsControl(Self);
    end;
    {$ELSE}
    PaintOnGlass := (csGlassPaint in ControlState) and (Picture.Graphic <> nil)
      and not Picture.Graphic.SupportsPartialTransparency;
    {$IFEND}
    if PaintOnGlass then
    begin
      Rect := DestRect;
      PaintBuffer := BeginBufferedPaint(DrawingCanvas.Handle, Rect, BPBF_TOPDOWNDIB, nil, MemDC);
      try
        DrawingCanvas.Handle := MemDC;
        DrawingCanvas.StretchDraw(DestRect, Picture.Graphic);
        BufferedPaintMakeOpaque(PaintBuffer, {$IF CompilerVersion <= 18}@{$IFEND}Rect);
      finally
        EndBufferedPaint(PaintBuffer, True);
      end;
    end
    else
    {$IFEND}
    begin
      DrawingCanvas.StretchDraw(DestRect, Picture.Graphic);
    end;
  finally
    BlockDrawing^ := Save;
  end;
end;

end.

Jetzt muß nur noch jemand die beiden DrawingCanvas.StretchDraw(DestRect, Picture.Graphic); ersetzen
und Testen ob es wirklich funktioniert.