Resize a *.jpg image and save the result to a file (2) (Views: 31)
Problem/Question/Abstract: 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? Answer: 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. { ... } 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; inc(yP, yP2); DstLine := pRGBArray(Integer(DstLine) + DstGap); end; end; end; function LoadJPEGPictureFile(Bitmap: TBitmap; FilePath, Filename: string): boolean; var JPEGImage: TJPEGImage; begin if (Filename = '') then {No filename so nothing to load - return false ...} Result := false else begin try JPEGImage := TJPEGImage.Create; try JPEGImage.LoadFromFile(FilePath + Filename); Bitmap.Assign(JPEGImage); Result := true; finally JPEGImage.Free; end; except Result := false; end; end; end; 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; end; end; except raise; Result := false; end; 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; end; 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; end; end; 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; end; end; |