Текущий архив: 2005.03.27;
Скачать: CL | DM;

Вниз

Как уменьшить картинку.   Найти похожие ветки 

← →
Alex Romanskiy ©   (2005-03-15 17:13) [0]

Есть image с загруженой в него картинкой. Можно ли стандартными способами Delphi уменьшить эту картинку, т.е. изменить ее масштаб? И если нет, то может есть какие-нибудь специальные компоненты для этого?
Спасибо.

---

← →
Eraser ©   (2005-03-15 17:15) [1]

Stretch

---

← →
Mamed   (2005-03-15 17:17) [2]

unit Unt_PictureResize;

interface

uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, JPEG,
 FileCtrl, extctrls;

type
 TRGBArray = array[Word] of TRGBTriple;
 pRGBArray = ^TRGBArray;
 TGif = class(TImage);
{---------------------------------------------------------------------------
-----------------------}
 procedure WMFtoBMP (Var WMFpic, JPGpic: String);
 function  GIFtoJPG (var GIFpic, JPGpic: string):boolean;
 function  BMPtoJPG (var BMPpic, JPGpic: string):boolean;
 Function ResizeImage(FileName: string; MaxWidth: Integer) : String;

implementation

procedure WMFtoBMP(Var WMFpic, JPGpic: String);
var
  Bitmap   : TBitmap;
  MetaFile : TMetafile;
  JpegImg  : TJpegImage;
begin
  Metafile := TMetaFile.Create;
  JpegImg  :=TJPEGImage.Create;
  Bitmap   :=TBitmap.Create;
  try
    MetaFile.LoadFromFile(WMFpic) ;
    with Bitmap do
    begin
      Height := Metafile.Height;
      Width := Metafile.Width;
      Canvas.Draw(0, 0, MetaFile) ;
      //SaveToFile(BMPFileName) ;
    end;
    JpegImg.Assign(Bitmap) ;
    JpegImg.SaveToFile(JPGpic);
  finally
    Bitmap.Free;
    MetaFile.Free;
    JpegImg.Free;
  end;
end;

function GIFtoJPG (var GIFpic, JPGpic: string):boolean;
var JpegImg    : TJpegImage;
   GifImg     : TGif;
   GetGIFFile : function (AFileName: PChar): HBITMAP; stdcall;
   hDLLInst   : THandle;
begin
 Result:=False;
 try
   JpegImg  :=TJPEGImage.Create;
   GifImg := TGif.Create(Nil);
   GifImg.Picture.LoadFromFile(GIFpic);
   hDLLInst:= LoadLibrary("GIFVIEW.DLL");
   if (hDLLInst > 0) then
   begin
     try
       GetGIFFile := GetProcAddress(hDLLInst,"GetGIFFile");
       if Assigned(GetGIFFile) then
         GifImg.Picture.Bitmap.Handle := GetGIFFile(PChar(GIFpic));
     finally
       FreeLibrary(hDLLInst);
     end;
   end;
   try
     JpegImg.Assign(GifImg.Picture.Bitmap) ;
     JpegImg.SaveToFile(JPGpic);
     Result:=True;
   finally
     JpegImg.Free;
   end;
 finally
  GifImg.Free;
 end;
end;

---

← →
Mamed   (2005-03-15 17:18) [3]

function BMPtoJPG (var BMPpic, JPGpic: string):boolean;
var Bitmap  : TBitmap;
   JpegImg : TJpegImage;
begin
 Result:=False;
 Bitmap := TBitmap.Create;
 try
  Bitmap.LoadFromFile(BMPpic) ;
  JpegImg := TJpegImage.Create;
  try
   JpegImg.Assign(Bitmap) ;
   JpegImg.SaveToFile(JPGpic) ;
   Result:=True;
  finally
   JpegImg.Free
  end;
 finally
  Bitmap.Free
 end;
end;

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}

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

---

← →
Mamed   (2005-03-15 17:18) [4]

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}

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

Function ResizeImage(FileName: string; MaxWidth: Integer) : String;
var
 OldBitmap      : TBitmap;
 NewBitmap      : TBitmap;
 aWidth         : Integer;
 WrongFN, CorFN : String;
begin
 Result   :="";
 WrongFN  :=FileName;
 CorFN    :=StringReplace(FileName, ExtractFileExt(FileName), ".jpg", [rfReplaceAll]);
 If UpperCase(ExtractFileExt(FileName))=".BMP" Then
 Begin
   BMPtoJPG(WrongFN, CorFN);
   FileName :=CorFN;
 End
 Else If UpperCase(ExtractFileExt(FileName))=".GIF" Then
 Begin
   GIFtoJPG(WrongFN, CorFN);
   FileName :=CorFN;
 End
 Else If UpperCase(ExtractFileExt(FileName))=".WMF" Then
 Begin
   WMFtoBMP(WrongFN, CorFN);
   FileName :=CorFN;
 End
 Else
 Begin
   Result  :=WrongFN;
   Exit;
 End;
 OldBitmap := TBitmap.Create;
 try
   LoadJPEGPictureFile(OldBitmap, ExtractFilePath(FileName), ExtractFileName(FileName));
   {if LoadJPEGPictureFile(OldBitmap, ExtractFilePath(FileName), ExtractFileName(FileName))=false 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}
 Result  :=CorFN;
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}

end.

---

← →
Mamed   (2005-03-15 17:19) [5]

Ispolzuy ResizeImage(FileName: string; MaxWidth: Integer) : Funchiyu no uchti kachestvo mojet teryatsya

---

← →
Fenik   (2005-03-15 17:50) [6]

>Mamed

Ой, мама. Он всего лишь спросил как уменьшить картинку.
Достаточный ответ: StretchDraw or StretchBlt -)

---

← →
_1   (2005-03-15 17:53) [7]

> Mamed   [2]..[5]


Ни фига себе "стандартные способы"! :)

---

← →
Alex Romanskiy ©   (2005-03-15 18:51) [8]

>Fenik
Спасибо. Пожалуй, это самый простой способ. :)

---

Страницы: 1 вся ветка

Текущий архив: 2005.03.27;
Скачать: CL | DM;

Наверх

Память: 0.5 MB
Время: 0.055 c