[PhoeniX]

Сабж в том, что мне надо отмасштабировать изображение под размер формы без изменения пропорций.
Изображение должно занимать всю форму (рамок по краям быть не должно), но и в то же время быть в наименьшем масштабе (не должно улезать за края там, где этого можно избежать).
Известны размеры изображения, и размеры прямоугольника, который надо заполнить.

Вопрос - по какой формуле можно пересчитать размеры, и как растянуть/сжать и обрезать изображение без особых потерь качества?

Можете просто записать пересчёт математически, подгоню сам.

Для примера, изображение 1280х800 надо вписать в 800х600.

[Страдалецъ]

А в чем подвох? Для TImage два свойства выставить в истину. Proportional и Stretch.

[roamer]

Где-то я встречал алгоритмы (в виде готовых процедур) "сжатия" картинок.
С объяснениями ...
Но хоть убейте - не могу вспомнить, где.
То ли в Инете. То ли в книжке.
Пороюсь сегодня-завтра. Если найду - кину ссылку.

[roamer]

Вот какой-то старый (в библах нашелся).
Но не помню, насколько он эффективен.

Код:

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;

[0nni]

Вот:

Код:

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);

[PhoeniX]

Сообщение от Страдалецъ

А в чем подвох? Для TImage два свойства выставить в истину. Proportional и Stretch.

Нифига подобного. Ибо сверху и снизу остаются рамки.

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;

Не работает.

[0nni]

Ну, если без рамок, то потеряются пропорции, либо придется отсекать часть изображения.
_______________
Можешь взять мой код и заменить

Код:

    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);

Тогда будет обрезать, но вписывать

[PhoeniX]

Вот, изначально говорилось - надо без рамок, можно отсекать.
Но тем не менее, даже

Код:

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;

не срабатывает. Можешь поправить?

[Страдалецъ]

Нифига подобного. Ибо сверху и снизу остаются рамки.

А вы интересно как себе это представляете, запихать картинку с соотношением сторон 8/5 в прямоугольник 8/6 и при этом не исказив его вписать без рамок?

Либо обрезать часть изображения, либо будут рамки по краям, других вариантов вроде не придумано.

[PhoeniX]

Обрезать, я ж изначально сказал!

[0nni]

Воспользуйся регионами:

Код:

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.

[roamer]

"Хорошая болезнь склероз. Ничего не болит и каждый день новости ...".
Или :
"Я вспомнил, группен-фюрер, я все вспомнил" - повторял Штирлиц, сидя на металлической, привинченной к полу кровати в подвале гестапо, при этом изображая честную уверенность в себе" ...
:-)

Вот в этом файле (DRKB3_Full.chm), который должен быть на http://www.drkb.ru/ (DRKB Explorer), есть раздел "Графические фильтры и эффекты". Там есть ряд алгоритмов, ориентированных на ReSize изображений ...