1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:

procedure TLabeledImage.ScaleImage(aWidth, aHeight: Integer);
var
  W, H: Double;
  L, T: Integer;
  aRect: TRect;
  aImage: TImage;
begin
 aImage := TImage.Create(Self);

 aImage.Canvas.Brush.Color := FColor;
 aImage.Canvas.FloodFill(0, 0, FColor, fsBorder);

 W := Picture.Width;
 H := Picture.Height;

 //Skalieren von grösser auf kleiner
 while (W > aWidth) or (H > aHeight) do
 begin
  W := W / 1.01;
  H := H / 1.01;
 end;

 //Hier skalieren von kleiner auf grösser, aber wie ???


 L := aWidth+1;
 T := aHeight+1;

 L := L mod Trunc(W) div 2;
 T := T mod Trunc(H) div 2;

 aRect := Rect(L, T, Trunc(W)+L, Trunc(H)+T);

 aImage.Canvas.CopyMode := cmSrcCopy;
 aImage.Canvas.StretchDraw(aRect, Picture.Graphic);

 Picture := aImage.Picture;

 Width := aRect.Right;
 Height := aRect.Bottom;

 aImage.Free;
end;					

1:
2:
3:
4:
5:
6:

//Skalieren von grösser auf kleiner
 while (W > aWidth) or (H > aHeight) do
 begin
  W := W / 1.01;
  H := H / 1.01;
 end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:

Procedure DrawGraphicToCanvas(Graphic:TGraphic;Canvas:TCanvas;Destrect:TRect);
var
    x,y,x1,y1:Double;
    Arect:TRect;
begin
      y:=Graphic.Height;
      x:=Graphic.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,Graphic);
end;


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;					

1:

DrawGraphicToCanvas(LabeledImage1.Picture.Graphic, LabeledImage1.Canvas, Rect(0,0,1024,768));					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:

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

 //Ohne diese Anweisung bleibt das Bild in Originalgrösse erhalten
 //und das verkleinerte Bild wird links oben gezeichnet.
 //Mit dieser Anweisung wird gar nichts gezeichnet.
 Image1.Picture.Bitmap := nil;

 Image1.Picture.Bitmap.Canvas.StretchDraw(zielrect,
  Image1.Picture.Bitmap);
end;					

1:
2:

Image1.Picture.Bitmap.Canvas.StretchDraw(zielrect,
  Image1.Picture.Bitmap);					

1:
2:
3:
4:
5:

 while (W > aWidth) or (H > aHeight) do
 begin
  W := W / 1.01;
  H := H / 1.01;
 end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,GDIPAPI,GDIPOBJ, StdCtrls, jpeg, ExtCtrls,ActiveX;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Button1: TButton;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
  private
  public
  end;
var
  Form1: TForm1;
implementation
{$R *.dfm}

// 20101104 by Thomas Wassermann AKA Bummi www.explido-software.de
// hochwertige Skalierungen von TBitmap und TGraphic
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;



procedure TForm1.Button1Click(Sender: TObject);
begin
 ScaleImage(image1.Picture.Graphic,Canvas,Rect(0,0,200,200));
 ScaleImage(image2.Picture.Bitmap,Canvas,Rect(200,200,400,400));
end;

end.					

1:

ScaleImage(Image1.Picture.Graphic, Image1.Canvas, Rect(0,0,200,200));					

1:

ScaleImage(Image1.Picture.Graphic, Image2.Canvas, Rect(0,0,200,200));