Как в Delphi изменять масштаб картинки?

При увеличении изображения нужно находить цвет точек, находящимися между
точками исходного изображения. Функция CopyRect, встроенная в Delphi берет
для этого цвет ближайшей точки. Увеличенное изображение получается некрасивым.
Чтобы избежать этого, используют интерполяцию.
Существует несколько видов интерполяции изображения. Наиболее простой из них - билинейный.

Изображение рассматривается как поверхность, цвет - третье измерение.
Если изображение цветное, то интерполяция проводится отдельно для трех цветов.
Для каждой точки нового изображения с координатами (xo,yo)
нужно найти четыре ближайшие точки исходного изображения.
Эти точки образуют квадрат. Через две верхние точки проводится прямая f1(x),
через две нижние - f2(x). Дальше находятся координаты для точек f1(xo) и f2(xo),
через которые проводится третья прямая f3(y). Цвет искомой точки - это f3(yo).

Этот алгоритм хорошо работает при целых или больших коэффициентах увеличения.
Но резкие границы размываются. Для уменьшения изображения этот алгоритм также не подходит.
Эта программа при нажатии на Button1 увеличивает часть изображения на экране,
а при нажатии на Button2 увеличивает открытое изображение.

Код

procedure Interpolate(var bm: TBitMap; dx, dy: single); var  bm1: TBitMap;  z1, z2: single;  k, k1, k2: single;  x1, y1: integer;  c: array [0..1, 0..1, 0..2] of byte;  res: array [0..2] of byte;  x, y: integer;  xp, yp: integer;  xo, yo: integer;  col: integer;  pix: TColor; begin  bm1 := TBitMap.Create;  bm1.Width := round(bm.Width * dx);  bm1.Height := round(bm.Height * dy);  for y := 0 to bm1.Height - 1 do begin    for x := 0 to bm1.Width - 1 do begin      xo := trunc(x / dx);      yo := trunc(y / dy);      x1 := round(xo * dx);      y1 := round(yo * dy);      for yp := 0 to 1 do        for xp := 0 to 1 do begin          pix := bm.Canvas.Pixels[xo + xp, yo + yp];          c[xp, yp, 0] := GetRValue(pix);          c[xp, yp, 1] := GetGValue(pix);          c[xp, yp, 2] := GetBValue(pix);        end;      for col := 0 to 2 do begin        k1 := (c[1,0,col] - c[0,0,col]) / dx;        z1 := x * k1 + c[0,0,col] - x1 * k1;        k2 := (c[1,1,col] - c[0,1,col]) / dx;        z2 := x * k2 + c[0,1,col] - x1 * k2;        k := (z2 - z1) / dy;        res[col] := round(y * k + z1 - y1 * k);      end;      bm1.Canvas.Pixels[x,y] := RGB(res[0], res[1], res[2]);    end;    Form1.Caption := IntToStr(round(100 * y / bm1.Height)) + '%';    Application.ProcessMessages;    if Application.Terminated then Exit;  end;  bm := bm1; end; const  dx = 5.5;  dy = 5.5; procedure TForm1.Button1Click(Sender: TObject); const  w = 50;  h = 50; var  bm: TBitMap;  can: TCanvas; begin  bm := TBitMap.Create;  can := TCanvas.Create;  can.Handle := GetDC(0);  bm.Width := w;  bm.Height := h;  bm.Canvas.CopyRect(Bounds(0, 0, w, h), can, Bounds(0, 0, w, h));  ReleaseDC(0, can.Handle);  Interpolate(bm, dx, dy);  Form1.Canvas.Draw(0, 0, bm);  Form1.Caption := 'x: ' + FloatToStr(dx) +    ' y: ' + FloatToStr(dy) +    ' width: ' + IntToStr(w) +    ' height: ' + IntToStr(h); end; procedure TForm1.Button2Click(Sender: TObject); var  bm: TBitMap; begin  if OpenDialog1.Execute then    bm.LoadFromFile(OpenDialog1.FileName);  Interpolate(bm, dx, dy);  Form1.Canvas.Draw(0, 0, bm);  Form1.Caption := 'x: ' + FloatToStr(dx) +    ' y: ' + FloatToStr(dy) +    ' width: ' + IntToStr(bm.Width) +    ' height: ' + IntToStr(bm.Height); end;

Эта программа строит заданные графики, используя модуль Recognition.
От констант left и right зависит диапазон x, от YScale зависит масштаб по y, а от k зависит качество прорисовки.

Код

uses Recognition; procedure TForm1.Button1Click(Sender: TObject); const  left = -10;  right = 10;  YScale = 50;  k = 10; var  i: integer;  Num: extended;  s: String;  XScale: single;  col: TColor; begin  s := Edit1.Text;  preparation(s, ['x']);  XScale := PaintBox1.Width / (right - left);  randomize;  col := RGB(random(100), random(100), random(100));  for i := round(left * XScale * k) to round(right * XScale * k) do    if recogn(ChangeVar(s, 'x', i / XScale / k), Num) then      PaintBox1.Canvas.Pixels[round(i / k - left * XScale),        round(PaintBox1.Height / 2 - Num * YScale)] := col; end;

Взято с сайта http://blackman.wp-club.net/
Добавлено @ 14:56
В Delphi изменять размеры изображения очень просто, используя CopyRect:

Код

procedure TForm1.Button1Click(Sender: TObject); begin  Form1.Canvas.Font.Size := 24;  Form1.Canvas.TextOut(0, 0, 'Text');  Form1.Canvas.CopyRect(Bounds(0, 50, 25, 10), Form1.Canvas,  Bounds(0, 0, 100, 40)); end;

Но этот способ не очень хорош для уменьшения не маленьких картинок – мелкие детали сливаются. Для частичного устранения этого недостатка при уменьшении изображения в четыре раза я беру средний цвет в каждом квадратике 4X4. К чему это приводит, посмотрите сами.

Код

procedure TForm1.Button1Click(Sender: TObject); var  x, y: integer;  i, j: integer;  r, g, b: integer; begin  Form1.Canvas.Font.Size := 24;  Form1.Canvas.TextOut(0, 0, 'Text');  for y := 0 to 10 do  begin    for x := 0 to 25 do    begin      r := 0;      for i := 0 to 3 do        for j := 0 to 3 do          r := r + GetRValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);      r := round(r / 16);      g := 0;      for i := 0 to 3 do        for j := 0 to 3 do          g := g + GetGValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);      g := round(g / 16);      b := 0;      for i := 0 to 3 do        for j := 0 to 3 do          b := b + GetBValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);      b := round(b / 16);      Form1.Canvas.Pixels[x,y+50] := RGB(r, g, b)    end;    Application.ProcessMessages;  end; end;

--------------------------------------------------------------------------------

Код

unit ProjetoX_Screen; interface uses  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,  ExtCtrls, StdCtrls, DBCtrls; type  TFormScreen = class(TForm)    ImgFundo: TImage;    procedure FormCreate(Sender: TObject);  public    MyRegion : HRGN;    function BitmapToRegion(hBmp: TBitmap; TransColor: TColor): HRGN;  end; var  FormScreen: TFormScreen; implementation {$R *.DFM} function TFormScreen.BitmapToRegion(hBmp: TBitmap; TransColor: TColor): HRGN; const  ALLOC_UNIT = 100; var  MemDC, DC: HDC;  BitmapInfo: TBitmapInfo;  hbm32, holdBmp, holdMemBmp: HBitmap;  pbits32 : Pointer;  bm32 : BITMAP;  maxRects: DWORD;  hData: HGLOBAL;  pData: PRgnData;  b, CR, CG, CB : Byte;  p32: pByte;  x, x0, y: integer;  p: pLongInt;  pr: PRect;  h: HRGN; begin  Result := 0;  if hBmp <> nil then  begin    MemDC := CreateCompatibleDC(0);    if MemDC <> 0 then    begin      with BitmapInfo.bmiHeader do      begin        biSize          := sizeof(TBitmapInfoHeader);        biWidth         := hBmp.Width;        biHeight        := hBmp.Height;        biPlanes        := 1;        biBitCount      := 32;        biCompression   := BI_RGB;        biSizeImage     := 0;        biXPelsPerMeter := 0;        biYPelsPerMeter := 0;        biClrUsed       := 0;        biClrImportant  := 0;      end;      hbm32 := CreateDIBSection(MemDC, BitmapInfo, DIB_RGB_COLORS, pbits32,0, 0);      if hbm32 <> 0 then      begin        holdMemBmp := SelectObject(MemDC, hbm32);        GetObject(hbm32, SizeOf(bm32), @bm32);        while (bm32.bmWidthBytes mod 4) > 0 do          inc(bm32.bmWidthBytes);        DC := CreateCompatibleDC(MemDC);        holdBmp := SelectObject(DC, hBmp.Handle);        BitBlt(MemDC, 0, 0, hBmp.Width, hBmp.Height, DC, 0, 0, SRCCOPY);        maxRects := ALLOC_UNIT;        hData := GlobalAlloc(GMEM_MOVEABLE, sizeof(TRgnDataHeader) +           SizeOf(TRect) * maxRects);        pData := GlobalLock(hData);        pData^.rdh.dwSize := SizeOf(TRgnDataHeader);        pData^.rdh.iType := RDH_RECTANGLES;        pData^.rdh.nCount := 0;        pData^.rdh.nRgnSize := 0;        SetRect(pData^.rdh.rcBound, MaxInt, MaxInt, 0, 0);        CR := GetRValue(ColorToRGB(TransColor));        CG := GetGValue(ColorToRGB(TransColor));        CB := GetBValue(ColorToRGB(TransColor));        p32 := bm32.bmBits;        inc(PChar(p32), (bm32.bmHeight - 1) * bm32.bmWidthBytes);        for y := 0 to hBmp.Height-1 do        begin          x := -1;          while x+1 < hBmp.Width do          begin            inc(x);            x0 := x;            p := PLongInt(p32);            inc(PChar(p), x * SizeOf(LongInt));            while x < hBmp.Width do            begin              b := GetBValue(p^);              if (b = CR) then              begin                b := GetGValue(p^);                if (b = CG) then                begin                  b := GetRValue(p^);                  if (b = CB) then                    break;                end;              end;              inc(PChar(p), SizeOf(LongInt));              inc(x);            end;            if x > x0 then            begin              if pData^.rdh.nCount >= maxRects then              begin                GlobalUnlock(hData);                inc(maxRects, ALLOC_UNIT);                hData := GlobalReAlloc(hData, SizeOf(TRgnDataHeader) +                   SizeOf(TRect) * maxRects, GMEM_MOVEABLE);                pData := GlobalLock(hData);                Assert(pData <> NIL);              end;              pr := @pData^.Buffer[pData^.rdh.nCount * SizeOf(TRect)];              SetRect(pr^, x0, y, x, y+1);              if x0 < pData^.rdh.rcBound.Left then                pData^.rdh.rcBound.Left := x0;              if y < pData^.rdh.rcBound.Top then                pData^.rdh.rcBound.Top := y;              if x > pData^.rdh.rcBound.Right then                pData^.rdh.rcBound.Left := x;              if y+1 > pData^.rdh.rcBound.Bottom then                pData^.rdh.rcBound.Bottom := y+1;              inc(pData^.rdh.nCount);              if pData^.rdh.nCount = 2000 then              begin                h := ExtCreateRegion(NIL, SizeOf(TRgnDataHeader) +                   (SizeOf(TRect) * maxRects), pData^);                Assert(h <> 0);                if Result <> 0 then                begin                  CombineRgn(Result, Result, h, RGN_OR);                  DeleteObject(h);                end else                  Result := h;                pData^.rdh.nCount := 0;                SetRect(pData^.rdh.rcBound, MaxInt, MaxInt, 0, 0);              end;            end;          end;          Dec(PChar(p32), bm32.bmWidthBytes);        end;        h := ExtCreateRegion(NIL, SizeOf(TRgnDataHeader) +           (SizeOf(TRect) * maxRects), pData^);        Assert(h <> 0);        if Result <> 0 then        begin          CombineRgn(Result, Result, h, RGN_OR);          DeleteObject(h);        end else          Result := h;        GlobalFree(hData);        SelectObject(DC, holdBmp);        DeleteDC(DC);        DeleteObject(SelectObject(MemDC, holdMemBmp));      end;    end;    DeleteDC(MemDC);  end; end; procedure TFormScreen.FormCreate(Sender: TObject); begin        MyRegion := BitmapToRegion(imgFundo.Picture.Bitmap,imgFundo.Canvas.Pixels[0,0]);        SetWindowRgn(Handle,MyRegion,True); end; procedure TFormXXXXXX.FormCreate(Sender: TObject); begin        FormScreen.MyRegion := FormScreen.BitmapToRegion(imgFundo.Picture.Bitmap,          imgFundo.Canvas.Pixels[0,0]);        SetWindowRgn(Handle,FormScreen.MyRegion,True); end;

Взято из http://delphiworld.narod.ru