Delphi Jpeg resmin çözünürlüğünü değiştirmek

[Blacklord]

(09-02-2022, Saat: 17:57)COMMANDX Adlı Kullanıcıdan Alıntı: Şu kodu bi deneyin

procedure ResizeBmp(Dest: TBitmap; const WMax, HMax: Word);
type
 pRGBArray = ^TRGBArray;
 TRGBArray = array[Word] of TRGBTriple;
var
 TBmp: TBitmap;
 DstGap: Integer;
 WNew, HNew: Integer;
 X, Y, T3: Integer;
 Z1, Z2, IZ2: Integer;
 W1, W2, W3, W4: Integer;
 XP, XP2, YP, YP2: Integer;
 SrcLine1, SrcLine2, DstLine: pRGBArray;
Begin
 TBmp := TBitmap.Create;
 try
   try
     WNew := (Dest.Width * HMax) div Dest.Height;
     HNew := (WMax * Dest.Height) div Dest.Width;
     if (WMax < WNew) then
     begin
       TBmp.Width := WMax;
       TBmp.Height := HNew;
     end else
     begin
       TBmp.Width := WNew;
       TBmp.Height := HMax;
     end;
     Dest.PixelFormat := pf24Bit;
     TBmp.PixelFormat := pf24bit;
     DstLine := TBmp.ScanLine[0];
     DstGap  := Integer(TBmp.ScanLine[1]) - Integer(DstLine);
     XP2 := MulDiv(Pred(Dest.Width), $10000, TBmp.Width);
     YP2 := MulDiv(Pred(Dest.Height), $10000, TBmp.Height);
     YP  := 0;
     for Y := 0 to Pred(TBmp.Height) do
     begin
       XP := 0;
       SrcLine1 := Dest.ScanLine[YP shr 16];
       if (YP shr 16 < Pred(Dest.Height))
         then SrcLine2 := Dest.ScanLine[Succ(YP shr 16)]
         else SrcLine2 := Dest.ScanLine[YP shr 16];
       Z2  := Succ(YP and $FFFF);
       IZ2 := Succ((not YP) and $FFFF);
       for X := 0 to Pred(TBmp.Width) do
       begin
         T3 := XP shr 16;
         Z1 := XP and $FFFF;
         W2 := MulDiv(Z1, IZ2, $10000);
         W1 := IZ2 - W2;
         W4 := MulDiv(Z1, 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;
       Inc(YP, YP2);
       DstLine := pRGBArray(Integer(DstLine) + DstGap);
     end;
     Dest.Assign(TBmp);
   except
   end;
 finally
   TBmp.Free;
 end;
end;

Denemedim 
Kullanımı

resizebmp(image1.picture.bitmap,640,480)

veya... 

  
   

procedure TForm1.Button2Click(Sender: TObject);
var
 bmp: TBitmap;
 jpg: TJPEGImage;
 scale: Double;
 widthL, HeightL, pt1, pt2, pt3, pt4: integer;
 verdd : boolean;
begin
 if OpenDialog1.Execute then
 begin
 try
         jpg := TJPEGImage.Create;
         verdd := false;
         try
           //Dimensões
           widthL := 98;
           HeightL := 98;
           jpg.LoadFromFile(OpenDialog1.FileName);
           if (jpg.Height >= jpg.Width) AND (HeightL <= jpg.Height) then begin
             scale := widthL / jpg.Height;
           end else if (jpg.Height <= jpg.Width) AND (widthL <=  jpg.Width) then begin
             scale := HeightL / jpg.Width;
           end else begin
             verdd := true;
           end;
               bmp := TBitmap.Create;
               try
                 {Create thumbnail bitmap, keep pictures aspect ratio}
                 bmp.SetSize( widthL,HeightL);
                 if not verdd then begin
                     pt1 := (widthL - Round(jpg.Width * scale)) div 2;
                     pt2 := (HeightL - Round(jpg.Height * scale)) div 2;
                     pt3 := Round(jpg.Width * scale) + pt1;
                     pt4 := Round(jpg.Height * scale) + pt2;
                     bmp.Canvas.StretchDraw(Rect(pt1, pt2, pt3, pt4), jpg);
                 end else begin
                     pt1 := (widthL - jpg.Width) div 2;
                     pt2 := (HeightL - jpg.Height) div 2;
                     pt3 := jpg.Width + pt1;
                     pt4 := jpg.Height + pt2;
                     bmp.Canvas.StretchDraw(Rect(pt1, pt2, pt3, pt4), jpg);
                 end;

                 Logo.Picture.Assign(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;
 except
      showMessage('Erro ao carregar imagem');    ///////////////////////////////////
 end;
 end;
end;

veya

Title: 
How to get/set JPG resolution
procedure GetResJpg(JPGFile: string);
const
 BufferSize = 50;
var
 Buffer: string;
 Index: integer;
 FileStream: TFileStream;
 HorzRes, VertRes: Word;
 DP: Byte;
 Measure: string;
begin
 FileStream := TFileStream.Create(JPGFile,
   fmOpenReadWrite);
 try
   SetLength(Buffer, BufferSize);
   FileStream.Read(buffer[1], BufferSize);
   Index := Pos('JFIF' + #$00, buffer);
   if Index  0 then
   begin
     FileStream.Seek(Index + 6, soFromBeginning);
     FileStream.Read(DP, 1);
     case DP of
       1: Measure := 'DPI'; //Dots Per Inch
       2: Measure := 'DPC'; //Dots Per Cm.
     end;
     FileStream.Read(HorzRes, 2); // x axis
     HorzRes := Swap(HorzRes);
     FileStream.Read(VertRes, 2); // y axis
     VertRes := Swap(VertRes);
   end
 finally
   FileStream.Free;
 end;
end;

procedure SetResJpg(name: string; dpix, dpiy: Integer);
const
 BufferSize = 50;
 DPI = 1; //inch
 DPC = 2; //cm
var
 Buffer: string;
 index: INTEGER;
 FileStream: TFileStream;
 xResolution: WORD;
 yResolution: WORD;
 _type: Byte;
begin
 FileStream := TFileStream.Create(name,
   fmOpenReadWrite);
 try
   SetLength(Buffer, BufferSize);
   FileStream.Read(buffer[1], BufferSize);
   index := POS('JFIF' + #$00, buffer);
   if index  0
     then begin
     FileStream.Seek(index + 6, soFromBeginning);
     _type := DPI;
     FileStream.write(_type, 1);
     xresolution := swap(dpix);
     FileStream.write(xresolution, 2);
     yresolution := swap(dpiy);
     FileStream.write(yresolution, 2);
   end
 finally
   FileStream.Free;
 end;
end;

Hocam yapamadım size zahmet olmazsa proje olarakgöderebilirmisiniz