При увеличении изображения нужно находить цвет точек, находящимися между
точками исходного изображения. Функция 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 |
