Показать сообщение отдельно
  #4  
Старый 07.06.2018, 20:51
lmikle lmikle вне форума
Модератор
 
Регистрация: 17.04.2008
Сообщения: 8,015
Версия Delphi: 7, XE3, 10.2
Репутация: 49089
По умолчанию

Ну, сжать можно так:
Код:
uses jpeg, math;

function CompressBitmapToJpeg(ASource : TBitmap; AWidth, AHeight : Integer) : TJpegImage;
var
  TargetBmp : TBitmap;
  K : Double;
  NewWidth, NewHeihg : Integer;
begin
  Result := Nil;
  TargetBmp := TBitmap.Create;
  TargetBmp.PixelsPerInch := pf24bit;
  Try
    If (ASource.Width <= AWidth) And (ASource.Height <= Height)
	  Then K := 1
	  Else K := Min(AWidth/ASource.Width, AHeight/ASource.Height);
	  NewWidth := Round(SourceBmp.Width*K);
	  NewHeight := Round(SourceBmp.Height*K);
	  TargetBmp.Width := NewWidth;
	  TargetBmp.Height := NewHeight;
	  TargetBmp.Canvas.StretchDraw(Rect(0,0,NewWidth,NewHeight),ASource);
	  Result := TJpegImage.Create;
	  Result.Assign(TargetBmp);    	
  Finally
	TargetBmp.Free;
  End;
end;

function CompressJpeg(ASource : TJpegImage; AWidth, AHeight : Integer) : TJpegImage;
var
  SourceBmp : TBitmap;
begin
  Result := Nil;
  If (ASource.Width <= AWidth) And (ASource.Height <= AHeight) 
    Then
      Begin
        // Do not need to copress jpeg, just copy source to target
	    Result := TJpegImage.Create;
		Result.Assign(ASource);
      End
    Else
      Begin
	    // Need to compress
	    SourceBmp := TBitmap.Create;
        Try
		  SourceBmp.Assign(ASource);
		  Result := CompressBitmapToJpeg(SourceBmp,AWidth,AHeigh);
        Finally
          SourceBmp.Free;
        End;
end;
На выходе функции получишь TJpegImage.
Перед сохранением установи его свойство CompressionQuality в желаемое значение (чем выше - тем выше качество, но и больше размер). Если правильно помню, то там от 1 до 100. Я бы рекомендовал где-то 60-70.

ЗЫ. Код не проверял, так что могут быть очепятки.
Ответить с цитированием