Полезное для программистов:

Фриланс
Новости
Статьи
   
Рубрики:


Изменение размеров JPEG Image?

Поиск:
Код
{

 Before importing an image (jpg) into a database,
 I would like to resize it (reduce its size) and
 generate the corresponding smaller file. How can I do this?


 Load the JPEG into a bitmap, create a new bitmap
 of the size that you want and pass them both into
 SmoothResize then save it again ...
 there's a neat routine JPEGDimensions that
 gets the JPEG dimensions without actually loading the JPEG into a bitmap,
 saves loads of time if you only need to test its size before resizing.
}



uses
 JPEG;

type
 TRGBArray = array[Word] of TRGBTriple;
 pRGBArray = ^TRGBArray;

{---------------------------------------------------------------------------
-----------------------}

procedure SmoothResize(Src, Dst: TBitmap);
var
 x, y: Integer;
 xP, yP: Integer;
 xP2, yP2: Integer;
 SrcLine1, SrcLine2: pRGBArray;
 t3: Integer;
 z, z2, iz2: Integer;
 DstLine: pRGBArray;
 DstGap: Integer;
 w1, w2, w3, w4: Integer;
begin
 Src.PixelFormat := pf24Bit;
 Dst.PixelFormat := pf24Bit;

 if (Src.Width = Dst.Width) and (Src.Height = Dst.Height) then
   Dst.Assign(Src)
 else
 begin
   DstLine := Dst.ScanLine[0];
   DstGap  := Integer(Dst.ScanLine[1]) - Integer(DstLine);

   xP2 := MulDiv(pred(Src.Width), $10000, Dst.Width);
   yP2 := MulDiv(pred(Src.Height), $10000, Dst.Height);
   yP  := 0;

   for y := 0 to pred(Dst.Height) do
   begin
     xP := 0;

     SrcLine1 := Src.ScanLine[yP shr 16];

     if (yP shr 16 < pred(Src.Height)) then
       SrcLine2 := Src.ScanLine[succ(yP shr 16)]
     else
       SrcLine2 := Src.ScanLine[yP shr 16];

     z2  := succ(yP and $FFFF);
     iz2 := succ((not yp) and $FFFF);
     for x := 0 to pred(Dst.Width) do
     begin
       t3 := xP shr 16;
       z  := xP and $FFFF;
       w2 := MulDiv(z, iz2, $10000);
       w1 := iz2 - w2;
       w4 := MulDiv(z, z2, $10000);
       w3 := z2 - w4;
       DstLine[x].rgbtRed := (SrcLine1[t3].rgbtRed * w1 +
         SrcLine1[t3 + 1].rgbtRed * w2 +
         SrcLine2[t3].rgbtRed * w3 + SrcLine2[t3 + 1].rgbtRed * w4) shr 16;
       DstLine[x].rgbtGreen :=
         (SrcLine1[t3].rgbtGreen * w1 + SrcLine1[t3 + 1].rgbtGreen * w2 +

         SrcLine2[t3].rgbtGreen * w3 + SrcLine2[t3 + 1].rgbtGreen * w4) shr 16;
       DstLine[x].rgbtBlue := (SrcLine1[t3].rgbtBlue * w1 +
         SrcLine1[t3 + 1].rgbtBlue * w2 +
         SrcLine2[t3].rgbtBlue * w3 +
         SrcLine2[t3 + 1].rgbtBlue * w4) shr 16;
       Inc(xP, xP2);
     end; {for}
     Inc(yP, yP2);
     DstLine := pRGBArray(Integer(DstLine) + DstGap);
   end; {for}
 end; {if}
end; {SmoothResize}

{---------------------------------------------------------------------------
-----------------------}

function LoadJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string): Boolean;
var
 JPEGImage: TJPEGImage;
begin
 if (FileName = '') then    // No FileName so nothing
   Result := False  //to load - return False...
 else
 begin
   try  // Start of try except
     JPEGImage := TJPEGImage.Create;  // Create the JPEG image... try  // now
     try  // to load the file but
       JPEGImage.LoadFromFile(FilePath + FileName);
       // might fail...with an Exception.
       Bitmap.Assign(JPEGImage);
       // Assign the image to our bitmap.Result := True;
       // Got it so return True.
     finally
       JPEGImage.Free;  // ...must get rid of the JPEG image. finally
     end; {try}
   except
     Result := False; // Oops...never Loaded, so return False.
   end; {try}
 end; {if}
end; {LoadJPEGPictureFile}


{---------------------------------------------------------------------------
-----------------------}


function SaveJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string;
 Quality: Integer): Boolean;
begin
 Result := True;
 try
   if ForceDirectories(FilePath) then
   begin
     with TJPegImage.Create do
     begin
       try
         Assign(Bitmap);
         CompressionQuality := Quality;
         SaveToFile(FilePath + FileName);
       finally
         Free;
       end; {try}
     end; {with}
   end; {if}
 except
   raise;
   Result := False;
 end; {try}
end; {SaveJPEGPictureFile}


{---------------------------------------------------------------------------
-----------------------}


procedure ResizeImage(FileName: string; MaxWidth: Integer);
var
 OldBitmap: TBitmap;
 NewBitmap: TBitmap;
 aWidth: Integer;
begin
 OldBitmap := TBitmap.Create;
 try
   if LoadJPEGPictureFile(OldBitmap, ExtractFilePath(FileName),
     ExtractFileName(FileName)) then
   begin
     aWidth := OldBitmap.Width;
     if (OldBitmap.Width > MaxWidth) then
     begin
       aWidth    := MaxWidth;
       NewBitmap := TBitmap.Create;
       try
         NewBitmap.Width  := MaxWidth;
         NewBitmap.Height := MulDiv(MaxWidth, OldBitmap.Height, OldBitmap.Width);
         SmoothResize(OldBitmap, NewBitmap);
         RenameFile(FileName, ChangeFileExt(FileName, '.$$$'));
         if SaveJPEGPictureFile(NewBitmap, ExtractFilePath(FileName),
           ExtractFileName(FileName), 75) then
           DeleteFile(ChangeFileExt(FileName, '.$$$'))
         else
           RenameFile(ChangeFileExt(FileName, '.$$$'), FileName);
       finally
         NewBitmap.Free;
       end; {try}
     end; {if}
   end; {if}
 finally
   OldBitmap.Free;
 end; {try}
end;


{---------------------------------------------------------------------------
-----------------------}

function JPEGDimensions(Filename : string; var X, Y : Word) : boolean;
var
 SegmentPos : Integer;
 SOIcount : Integer;
 b : byte;
begin
 Result  := False;
 with TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone) do
 begin
   try
     Position := 0;
     Read(X, 2);
     if (X <> $D8FF) then
       exit;
     SOIcount  := 0;
     Position  := 0;
     while (Position + 7 < Size) do
     begin
       Read(b, 1);
       if (b = $FF) then begin
         Read(b, 1);
         if (b = $D8) then
           inc(SOIcount);
         if (b = $DA) then
           break;
       end; {if}
     end; {while}
     if (b <> $DA) then
       exit;
     SegmentPos  := -1;
     Position    := 0;
     while (Position + 7 < Size) do
     begin
       Read(b, 1);
       if (b = $FF) then
       begin
         Read(b, 1);
         if (b in [$C0, $C1, $C2]) then
         begin
           SegmentPos  := Position;
           dec(SOIcount);
           if (SOIcount = 0) then
             break;
         end; {if}
       end; {if}
     end; {while}
     if (SegmentPos = -1) then
       exit;
     if (Position + 7 > Size) then
       exit;
     Position := SegmentPos + 3;
     Read(Y, 2);
     Read(X, 2);
     X := Swap(X);
     Y := Swap(Y);
     Result  := true;
   finally
     Free;
   end; {try}
 end; {with}
end; {JPEGDimensions}


Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php

---------------------------------------------------------------------------------

загрузи в bitmap, измени размеры, сделай Stretch и сохрани.

Код
procedure TForm1.Button1Click(Sender: TObject);
var
 bmp: TBItmap;
 jpg: TJpegImage;
 scale: Double;
begin
 if opendialog1.execute then
 begin
   jpg := TJpegImage.Create;
   try
     jpg.Loadfromfile( opendialog1.filename );
     if jpg.Height > jpg.Width then
       scale := 50 / jpg.Height
     else
       scale := 50 / jpg.Width;
     bmp:= Tbitmap.Create;
     try
       {Create thumbnail bitmap, keep pictures aspect ratio}
       bmp.Width := Round( jpg.Width * scale );
       bmp.Height:= Round( jpg.Height * scale );
       bmp.Canvas.StretchDraw( bmp.Canvas.Cliprect, jpg );
       {Draw thumbnail as control}
       Self.Canvas.Draw( 100, 10, bmp );
       {Convert back to JPEG and save to file}
       jpg.Assign( bmp );
       jpg.SaveToFile(ChangeFileext( opendialog1.filename, '_thumb.JPG' ));
     finally
       bmp.free;
     end;
   finally
     jpg.free;
   end;
 end;
end;


Не забудь USES Jpeg;

Автор RoboSol
Взято из http://forum.sources.ru
Автор: DRKB






Просмотров: 2251

 

 

Новые статьи:


Популярные:
  1. Как сделать цикличным проигрывание MIDI-файла?
  2. Создание AVI файла из рисунков
  3. Как устройство "отключить в данной конфигурации"?
  4. Kто в данный момент присоединен через Сеть?
  5. Как узнать количество доступной памяти?
  6. Как реализовать в RichEdit разноцветный текст?
  7. Как скрыть свое приложение от ProcessViewer
  8. Как программно нажать/скрыть/показ кнопку "Start"?
  9. Модуль работы с ресурсами в PE файлах
10. Функции вызова диалоговых окон выбора
11. Проверка граматики средствами Word'а из Delphi.
12. Модуль для упрощенного вызова сообщений
13. Функции для записи и чтение своих данных в, ЕХЕ- файле
14. Рекурсивный просмотр директорий
15. Network Traffic Monitor
16. Разные модули
17. Универсальная функция для обращения к любым экспортируем функциям DLL
18. Библиотека от VladS
19. Протектор для UPX'а
20. Еще об ICQ, сообщения по контакт листу?
21. Использование открытых интерфейсов
22. Теория и практика использования RTTI
23. Работа с TApplication
24. Примеры использования Drag and Drop для различных визуальных компонентов
25. Что такое порт? Правила для работы с портами
26. Симфония на клавиатуре
27. Загрузка DLL
28. Исправление автоинкремента
29. Взаимодействие с чужими окнами
30. Проверить дубляжи в столбце


 

 

 
 
На главную