Подскажите как качественно уменьшить размер картинки

← →
Chaser © (2005-06-27 10:00) [0]

Вопрос: как можно изменить (уменьшить) размер картинки без значительной потери качества, примерно так как делает Фотошоп (Image Size).

Сам делаю так:

Bmp:=TBitmap.Create;
jpg:=TJpegImage.Create;
Bmp.Width:=Form1.Width;
Bmp.Height:=Form1.Height;
dc:=GetWindowDC(GetDesktopWindow);
Bmp.Width:=Form1.Width;
Bmp.Height:=Form1.Height;
BitBlt(Bmp.Canvas.Handle,0,0,Form1.Width,Form1.Height,dc,Form1.Top+8,Form1.Left-8,SRCCOPY);
// уменьшение картинки
jpg.Assign(Bmp);
ReleaseDC(GetDesktopWindow, dc);
// уменьшение картинки
if jpg.Height>jpg.Width
then scale:=650 / jpg.Height
else scale:=650 / jpg.Width;
//
Bmp.Width:=Round(jpg.Width * scale);
Bmp.Height:=Round(jpg.Height * scale);
Bmp.Canvas.StretchDraw(Bmp.Canvas.Cliprect, jpg);
// Convert back to JPEG and save to file
jpg.Assign(bmp);
//
jpg.CompressionQuality:=70;
// "Оттенки серого" false
jpg.Grayscale:=false;
// упаковываем графику
jpg.Compress;
//
jpg.SaveToFile(ExtractFilePath(Application.ExeName)+"prog_screen.jpg");
//
Bmp.FreeImage;
FreeAndNil(Bmp);
jpg.Free;

Но в итоге на рисунке ничего не разоберешь, некоторые куски исходного рисунка пропадают, все куда-то сбивается.

Подскажите плиз как качественно уменьшить размер картинки.

← →
Chaser © (2005-06-27 13:39) [1]

Проблема решена:

procedure SmoothResize(Width, Height : integer; S,D : TBitmap);
type
TRGBArray = array[Word] of TRGBTriple;
pRGBArray = ^TRGBArray;
var
x, y: Integer;
xP, yP: Integer;
Mx, My: Integer;
SrcLine1, SrcLine2: pRGBArray;
t3: Integer;
z, z2, iz2: Integer;
DstLine: pRGBArray;
DstGap: Integer;
w1, w2, w3, w4: Integer;
begin
S.PixelFormat:=pf24Bit;
D.PixelFormat:=pf24Bit;
if Width*Height=0
then
begin
D.Assign(S);
Exit;
end;
D.Width:=Width;
D.Height:=Height;
if (S.Width = D.Width) and (S.Height = D.Height)
then D.Assign(S)
else
begin
DstLine := D.ScanLine[0];
DstGap := Integer(D.ScanLine[1]) - Integer(DstLine);
Mx := MulDiv(pred(S.Width), $10000, D.Width);
My := MulDiv(pred(S.Height), $10000, D.Height);
yP := My;
for y := 0 to pred(D.Height) do
begin
xP := Mx;
t3:=yP shr 16;
if (t3 < pred(S.Height))
then
begin
dec(t3);
if t3<0 then inc(t3);
SrcLine1 := S.ScanLine[t3];
SrcLine2 := S.ScanLine[succ(t3)];
end
else
begin
SrcLine1 := S.ScanLine[S.Height-2];
SrcLine2 := S.ScanLine[S.Height-1];
end;
z2 := succ(yP and $FFFF);
iz2 := succ((not yp) and $FFFF);
for x := 0 to pred(D.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;
dec(t3);
if t3<0 then inc(t3);
if t3>=S.Width-1 then t3:=S.Width-2;
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, Mx);
end;
Inc(yP, My);
DstLine := pRGBArray(Integer(DstLine) + DstGap);
end;
end;
end;

← →
WondeRu © (2005-06-28 18:29) [2]

а StretchBlt чем плох?

← →
Thaddy (2005-06-29 11:52) [3]

That is indeed far better. I suggest stretchBlt the image X 4, and use quadratic interpolation for very high quality, slightly slow, resize to the new picture size that is 2 times smaller than the original, or simple linear (like above) interpolation for good quality.
The sourcecode here gives slighly blurred results without oversampling. So: To improve, simply strechblt first, then use the code above. The results will be much, much better! But slower of course.

← →
Stexen (2005-06-30 01:21) [4]

Ты какой то виртуоз!!!
По-моему легче сделать стречблт а потом фильтр применить :)

Подскажите как качественно уменьшить размер картинки Найти похожие ветки