Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Текущий архив: 2005.11.20;
Скачать: CL | DM;

Вниз

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

 
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]

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



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

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

Наверх




Память: 0.46 MB
Время: 0.049 c
6-1123497734
ronyn
2005-08-08 14:42
2005.11.20
Как синхронизировать страницу?


3-1128661433
syte_ser78
2005-10-07 09:03
2005.11.20
Перевод БД на другой язык


2-1130842380
stud
2005-11-01 13:53
2005.11.20
запуск нескольких программ в консоли


2-1130522535
PUZZZ
2005-10-28 22:02
2005.11.20
Программа для создания и хранения RTF-документов в виде структуры


1-1130527472
Arazel
2005-10-28 23:24
2005.11.20
TabControl > TabsScroll (CUSTOMDRAW)





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский