JPG verkleinern

[Lord Dave]

Hi,

ich hatte auch schonmal das Problem, hatte dann irgendwo im tiefsten chinesischen (oder japanischen?) Internet-Untergrund eine nützliche Funktion gefunden:

Die eigentliche Methode:

Code:

procedure CreateThumbnail(InStream, OutStream: TStream; Width, Height: Integer; Compress: Boolean; ProgressEvent : TProgressEvent); overload;
var
  JpegImage: TJpegImage;
  Bitmap: TBitmap;
  Ratio: Double;
  ARect: TRect;
  AHeight (*, AHeightOffset*): Integer;
  AWidth (*, AWidthOffset*): Integer;
begin
//  Check for invalid parameters
  JpegImage := TJpegImage.Create;
  try
//  Load the image
    JpegImage.LoadFromStream(InStream);
    if Width = 0 then
      Width := JpegImage.Width;
    if Height = 0 then
      Height := JpegImage.Height;

    // Create bitmap, and calculate parameters
    Bitmap := TBitmap.Create;
    try
      Ratio := JpegImage.Width / JpegImage.Height;
      if Ratio > 1 then
      begin
        AHeight := Round(Width / Ratio);
//        AHeightOffset:=(Height-AHeight) div 2;
        AWidth := Width;
//        AWidthOffset:=0;
      end
      else
      begin
        AWidth := Round(Height * Ratio);
//        AWidthOffset:=(Width-AWidth) div 2;
        AHeight := Height;
//        AHeightOffset:=0;
      end;

      Bitmap.Width := AWidth;
      Bitmap.Height := AHeight;
//      Bitmap.Canvas.Brush.Color:=FillColor;
//      Bitmap.Canvas.FillRect(Rect(0,0,Width,Height));
// StretchDraw original image
//      ARect:=Rect(AWidthOffset,AHeightOffset,AWidth+AWidthOffset,AHeight+AHeightOffset);
      ARect := Rect(0, 0, AWidth, AHeight);
      Bitmap.Canvas.StretchDraw(ARect, JpegImage);
// Assign back to the Jpeg, and save to the file
      JpegImage.Free;

      JpegImage := TJpegImage.Create;
      JpegImage.OnProgress := ProgressEvent;
      JpegImage.Assign(Bitmap);

      if Compress then
        JpegImage.CompressionQuality := 30;
     
      JpegImage.SaveToStream(OutStream);
    finally
      Bitmap.Free;
    end;
  finally
    JpegImage.Free;
  end;
end;

Überladen, nur Dateinamen und max-Größen angeben:

Code:

procedure CreateThumbnail(const InFileName, OutFileName: string; Width, Height: Integer; Compress: Boolean; ProgressEvent : TProgressEvent); overload;
var
  InStream, OutStream: TFileStream;
begin
  InStream := TFileStream.Create(InFileName, fmOpenRead);
  try
    OutStream := TFileStream.Create(OutFileName, fmOpenWrite or fmCreate);
    try
      CreateThumbnail(InStream, OutStream, Width, Height, Compress, ProgressEvent);
    finally
      OutStream.Free;
    end;
  finally
    InStream.Free;
  end;
end;

Progressing Event, der aufgerufen wird (mit Beispiel für JvXpProgressbar):

Code:

    procedure progressing(Sender: TObject; Stage: TProgressStage;
    PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
...

procedure TForm1.progressing(Sender: TObject; Stage: TProgressStage;
    PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
  JvXpProgressBar1.Position := PercentDone;
  Application.ProcessMessages;
end;

Hier ein Anwendungsbeispiel:

Code:

procedure TForm1.JvXPButton7Click(Sender: TObject);
var newFilename: string;
    streamIn, streamOut: TFileStream;
begin
  if OpenPictureDialog1.Execute then
  begin
    titelbild := OpenPictureDialog1.Filename;
    streamIn := TFileStream.Create(titelbild,fmOpenRead);
    newFilename := AppPath+ChangeFileExt(ExtractFileName(titelbild),'_thumb.jpg');
    streamOut := TFileStream.Create(newFilename,fmCreate);

    CreateThumbnail((streamIn), (streamOut),200,200,false,progressing);
    //; Width, Height: Integer; Compress: Boolean; ProgressEvent : TProgressEvent); overload;
    streamIn.Free;
    streamOut.Free;
    Thumb1.LoadFromFile(titelbild);
  end;

end;

Funktioniert prima!