|
|
Регистрация | << Правила форума >> | FAQ | Пользователи | Календарь | Поиск | Сообщения за сегодня | Все разделы прочитаны |
|
Опции темы | Поиск в этой теме | Опции просмотра |
#1
|
||||
|
||||
Масштабирование изображения
Сабж в том, что мне надо отмасштабировать изображение под размер формы без изменения пропорций.
Изображение должно занимать всю форму (рамок по краям быть не должно), но и в то же время быть в наименьшем масштабе (не должно улезать за края там, где этого можно избежать). Известны размеры изображения, и размеры прямоугольника, который надо заполнить. Вопрос - по какой формуле можно пересчитать размеры, и как растянуть/сжать и обрезать изображение без особых потерь качества? Можете просто записать пересчёт математически, подгоню сам. Для примера, изображение 1280х800 надо вписать в 800х600. Оставайтесь хорошими людьми... VK id2634397, ds [at] phoenix [dot] dj |
#2
|
||||
|
||||
А в чем подвох? Для TImage два свойства выставить в истину. Proportional и Stretch.
Жизнь такова какова она есть и больше никакова. Помогаю за спасибо. |
#3
|
|||
|
|||
Где-то я встречал алгоритмы (в виде готовых процедур) "сжатия" картинок.
С объяснениями ... Но хоть убейте - не могу вспомнить, где. То ли в Инете. То ли в книжке. Пороюсь сегодня-завтра. Если найду - кину ссылку. |
#4
|
|||
|
|||
Вот какой-то старый (в библах нашелся).
Но не помню, насколько он эффективен. Код:
function ResizeBMP_to_small(BMP0 : TBitmap; Kx : real) : boolean; //Масштабирование (уменьшение) BitMap Type TRGBTripleArray = array[word] of TRGBTriple; pRGBTripleArray = ^TRGBTripleArray; Var BMP_x: TBitMap; Yes : byte; kkk : integer; i : integer; j : integer; lookup : integer; RowIn : pRGBTripleArray; RowOut : pRGBTripleArray; begin Result:=FALSE; Yes:=0; if Kx>=0.9999999999 then begin if BMP0<>NIL then begin if BMP0.Width>0 then begin if BMP0.Height>0 then begin if round(Kx)<BMP0.Width then begin if round(Kx)<BMP0.Height then begin Yes:=1; end; end; end; end; end; if Yes>0 then begin //ShowMessage('1'); BMP_x := TBitmap.Create; TRY BMP_x.Width := round(BMP0.Width / Kx); BMP_x.Height := round(BMP0.Height / Kx); BMP_x.PixelFormat := pf24bit; for j := 0 to (BMP_x.Height-1) do begin kkk:=round(Kx*j); RowIn := BMP0.Scanline[kkk]; RowOut := BMP_x.Scanline[j]; for i := 0 to (BMP_x.Width-1) do begin lookup := round(Kx*i); RowOut[i] := RowIn[lookup]; end; end; BMP0.Assign(BMP_x); Result:=TRUE; FINALLY BMP_x.Free; END; end; end; end; |
#5
|
||||
|
||||
Вот:
Код:
procedure DrawBitmaptRect(dc : hdc; bmp : HBITMAP; Rect : TRect); var cdc : HDC; bInfo : TBitmapInfo; prevSetStretchBltMode : Integer; dx, dy, dr : Double; BitmapCx, BitmapCy : Integer; ClipCx, ClipCy : Integer; OffsX, OffxY : Integer; begin cdc := CreateCompatibleDC(dc); SelectObject(cdc, bmp); GetObject(bmp, SizeOf(bInfo), @Binfo); ClipCx := Rect.Right - Rect.Left; ClipCy := Rect.Bottom - Rect.Top; OffsX := Rect.Left; OffxY := Rect.Top; BitmapCx := Binfo.bmiHeader.biWidth; BitmapCy := bInfo.bmiHeader.biHeight; //Считаем оптимальный размер if (BitmapCx > ClipCx)or(BitmapCy > ClipCy) then begin dx := ClipCx / BitmapCx; dy := ClipCy / BitmapCy; //dr := min(dx, dy); if dx < dy then dr := dx else dr := dy; Rect.Right := Trunc(BitmapCx * dr); Rect.Bottom := Trunc(BitmapCY * dr); end else begin Rect.Right := BitmapCx; Rect.Bottom := BitmapCy; end; //Центрируес Rect.Left := (ClipCx - Rect.Right) div 2; Rect.Top := (ClipCy - Rect.Bottom) div 2; OffsetRect(Rect, OffsX, OffxY); //Рисуем со сглаживанием prevSetStretchBltMode := SetStretchBltMode(dc, HALFTONE); with Rect do StretchBlt(dc, Left, Top, Right - OffsX, Bottom - OffxY, cdc, 0, 0, BitmapCx, BitmapCy, SRCCOPY); SetStretchBltMode(dc, prevSetStretchBltMode); DeleteDC(cdc); end; Рисуй так Код:
DrawBitmaptRect(Canvas.Handle, Bitmap.Handle, GetClientRect); ...сказал, и загрустил от бесспорной своей правоты Последний раз редактировалось 0nni, 20.09.2009 в 20:23. |
#6
|
||||
|
||||
Цитата:
0nni, Код:
procedure LoadMainBack; var sr:TSearchRec; path: string; i:integer; dat: TStringList; r:TRect; begin dat:=TStringList.Create; path:=ExtractFilePath(ParamStr(0))+'load\'; i:=FindFirst(path+'*.jpg',faAnyFile xor faDirectory,sr); while i=0 do begin i:=FindNext(sr); dat.Add(path+sr.Name); end; FindClose(sr); i:=FindFirst(path+'*.jpeg',faAnyFile xor faDirectory,sr); while i=0 do begin i:=FindNext(sr); dat.Add(path+sr.Name); end; FindClose(sr); i:=FindFirst(path+'*.bmp',faAnyFile xor faDirectory,sr); while i=0 do begin i:=FindNext(sr); dat.Add(path+sr.Name); end; FindClose(sr); frmMain.Image1.Picture.RegisterFileFormat('.jpg','JPEG Image',TJPEGImage); frmMain.Image1.Picture.RegisterFileFormat('.jpeg','JPEG Image',TJPEGImage); frmMain.Image1.Picture.LoadFromFile(dat[Random(dat.Count-1)]); GetClientRect(frmMain.Handle,r); DrawBitmaptRect(frmMain.Canvas.Handle, frmMain.Image1.Picture.Bitmap.Handle, r); dat.Clear; dat.Free; end; Оставайтесь хорошими людьми... VK id2634397, ds [at] phoenix [dot] dj Последний раз редактировалось PhoeniX, 20.09.2009 в 19:44. |
#7
|
||||
|
||||
Ну, если без рамок, то потеряются пропорции, либо придется отсекать часть изображения.
_______________ Можешь взять мой код и заменить Код:
dx := ClipCx / BitmapCx; dy := ClipCy / BitmapCy; //dr := min(dx, dy); if dx > dy then dr := dx else dr := dy; //<<< эту строчку Rect.Right := Trunc(BitmapCx * dr); Rect.Bottom := Trunc(BitmapCY * dr); Тогда будет обрезать, но вписывать ...сказал, и загрустил от бесспорной своей правоты Последний раз редактировалось 0nni, 20.09.2009 в 19:45. |
#8
|
||||
|
||||
Вот, изначально говорилось - надо без рамок, можно отсекать.
Но тем не менее, даже Код:
procedure LoadMainBack; var sr:TSearchRec; path: string; i:integer; dat: TStringList; r:TRect; j: TJPEGImage; b: TBitmap; begin dat:=TStringList.Create; path:=ExtractFilePath(ParamStr(0))+'load\'; i:=FindFirst(path+'*.jpg',faAnyFile xor faDirectory,sr); while i=0 do begin i:=FindNext(sr); dat.Add(path+sr.Name); end; FindClose(sr); j:=TJPEGImage.Create; j.LoadFromFile(dat[Random(dat.Count-1)]); b:=TBitmap.Create; b.Assign(j); GetClientRect(frmMain.Handle,r); DrawBitmaptRect(frmMain.Image1.Picture.Bitmap.Canvas.Handle, b.Handle, r); dat.Clear; dat.Free; end; Оставайтесь хорошими людьми... VK id2634397, ds [at] phoenix [dot] dj |
#9
|
||||
|
||||
Цитата:
Либо обрезать часть изображения, либо будут рамки по краям, других вариантов вроде не придумано. Жизнь такова какова она есть и больше никакова. Помогаю за спасибо. |
#10
|
||||
|
||||
Обрезать, я ж изначально сказал!
Оставайтесь хорошими людьми... VK id2634397, ds [at] phoenix [dot] dj |
#11
|
||||
|
||||
Воспользуйся регионами:
Код:
unit mAIN; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtDlgs; type TForm1 = class(TForm) OpenPictureDialog1: TOpenPictureDialog; procedure FormClick(Sender: TObject); procedure FormPaint(Sender: TObject); procedure FormResize(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } bmp : TBitmap; end; var Form1: TForm1; implementation {$R *.dfm} procedure DrawBitmaptRect(dc : hdc; bmp : HBITMAP; Rect : TRect); var cdc : HDC; bInfo : TBitmapInfo; prevSetStretchBltMode : Integer; dx, dy, dr : Double; BitmapCx, BitmapCy : Integer; ClipCx, ClipCy : Integer; OffsX, OffxY : Integer; begin cdc := CreateCompatibleDC(dc); SelectObject(cdc, bmp); GetObject(bmp, SizeOf(bInfo), @Binfo); ClipCx := Rect.Right - Rect.Left; ClipCy := Rect.Bottom - Rect.Top; OffsX := Rect.Left; OffxY := Rect.Top; BitmapCx := Binfo.bmiHeader.biWidth; BitmapCy := bInfo.bmiHeader.biHeight; //Считаем оптимальный размер if (BitmapCx > ClipCx)or(BitmapCy > ClipCy) then begin dx := ClipCx / BitmapCx; dy := ClipCy / BitmapCy; //dr := min(dx, dy); //if dx < dy then dr := dx else dr := dy; if dx > dy then dr := dx else dr := dy; Rect.Right := Trunc(BitmapCx * dr); Rect.Bottom := Trunc(BitmapCY * dr); end else begin Rect.Right := BitmapCx; Rect.Bottom := BitmapCy; end; //Центрируес Rect.Left := (ClipCx - Rect.Right) div 2; Rect.Top := (ClipCy - Rect.Bottom) div 2; OffsetRect(Rect, OffsX, OffxY); //Рисуем со сглаживанием prevSetStretchBltMode := SetStretchBltMode(dc, HALFTONE); with Rect do StretchBlt(dc, Left, Top, Right - OffsX, Bottom - OffxY, cdc, 0, 0, BitmapCx, BitmapCy, SRCCOPY); SetStretchBltMode(dc, prevSetStretchBltMode); DeleteDC(cdc); end; procedure TForm1.FormClick(Sender: TObject); begin if not OpenPictureDialog1.Execute then exit; bmp.LoadFromFile(OpenPictureDialog1.FileName); Caption := OpenPictureDialog1.FileName + ' - zeView'; Invalidate; end; procedure TForm1.FormCreate(Sender: TObject); var sz : TSize; Str : string; begin bmp := TBitmap.Create; str := 'Click to open bitmap file...'; GetTextExtentPoint32(bmp.Canvas.Handle, Pchar(str), Length(str), sz); bmp.Width := sz.cx; bmp.Height := sz.cy; bmp.Canvas.TextOut(0, 0, str); DoubleBuffered := true; OpenPictureDialog1.Filter := '*.bmp|*.bmp'; Caption := 'zeView'; end; procedure TForm1.FormPaint(Sender: TObject); var ClipRgn : HRGN; Rt : TRect; begin //Моя функция не образает т.к. по логике изображение не выходит //за граници прямоугольника //в твоем случае такая логика не работает, поэтому //можно использовать регионы Rt := rect(8, 8, ClientWidth - 8, ClientHeight - 8); ClipRgn := CreateRectRgn(8, 8, ClientWidth - 8, ClientHeight - 8); SelectClipRgn(Canvas.Handle, ClipRgn); DrawBitmaptRect(Canvas.Handle, bmp.Handle, rt); SelectClipRgn(Canvas.Handle, 0); DeleteObject(ClipRgn); end; procedure TForm1.FormResize(Sender: TObject); begin Invalidate; end; end. ...сказал, и загрустил от бесспорной своей правоты |
#12
|
|||
|
|||
"Хорошая болезнь склероз. Ничего не болит и каждый день новости ...".
Или : "Я вспомнил, группен-фюрер, я все вспомнил" - повторял Штирлиц, сидя на металлической, привинченной к полу кровати в подвале гестапо, при этом изображая честную уверенность в себе" ... :-) Вот в этом файле (DRKB3_Full.chm), который должен быть на http://www.drkb.ru/ (DRKB Explorer), есть раздел "Графические фильтры и эффекты". Там есть ряд алгоритмов, ориентированных на ReSize изображений ... |